home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / 4c.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  73.9 KB  |  2,531 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. #include "4.h"
  10. #include "attr.h"
  11. #include "setprots.h"
  12. #include "libprots.h"
  13. #include "miscprots.h"
  14. #include "smiscprots.h"
  15. #include "errmsgprots.h"
  16. #include "nodesprots.h"
  17. #include "dclmapprots.h"
  18. #include "evalprots.h"
  19. #include "chapprots.h"
  20.  
  21. static int prev_error_message;
  22. static Triplet *is_partition(Tuple, int, int);
  23. static Tuple sort_case(Tuple);
  24. static int tcompar(Triplet **, Triplet **);
  25. static int abs_val(int);
  26. static void complete_a_aggregate(Tuple, Tuple, Symbol, int, Node);
  27. static void complete_component(Tuple, Tuple, Symbol, int, Node);
  28. static Node new_comp_assoc(Symbol, Node);
  29. static void resolve_r_component(Node, Symbol, Tuple);
  30. static Symbol check_discriminant_dependence(Symbol, Tuple);
  31. static int in_gen_types(Symbol);
  32. static int in_multiple_types(Symbol);
  33. static int is_integer_type(Symbol);
  34. static Triplet *triplet_new();
  35.  
  36. int can_constrain(Symbol d_type)                          /*;can_constrain*/
  37. {
  38.     /* Determine whether an object, actual parameter,  type def, etc.  can
  39.      * receive a constraint.The predicate -is_unconstrained- used in decla-
  40.      * rations is too weak here, because it returns false on discriminated
  41.      * records with default values.
  42.      */
  43.  
  44.     if ((NATURE(d_type) == na_array)
  45.       || (is_record(d_type) && NATURE(d_type) != na_subtype
  46.       && has_discriminants(d_type)))
  47.         return TRUE;
  48.     else
  49.         return FALSE;
  50. }
  51.  
  52. Set valid_array_expn(Node expn)                             /*;valid_array_expn*/
  53. {
  54.     /* Called to validate indexing and slicing operations. The array name may
  55.      * be overloaded, and may also be an access to an array type. 
  56.      */
  57.  
  58.     Node    a_expn, i_node;
  59.     Set array_types, types, rset;
  60.     Tuple    index_list;
  61.     Node    index;
  62.     Symbol    n, a_t, t;
  63.     int        i, exists, forall;
  64.     Symbol    i_t;
  65.     Forset    fs1, fs2;
  66.     Fortup    ft1;
  67.  
  68.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  valid_array_expn");
  69.  
  70.     a_expn = N_AST1(expn);
  71.     i_node = N_AST2(expn);
  72.     resolve1(a_expn);
  73.     types = N_PTYPES(a_expn);
  74.     index_list = N_LIST(i_node);
  75.     array_types = set_new(0);    /* To collect valid types*/
  76.     FORTUP(index = (Node), index_list, ft1);
  77.         n = N_UNQ(index);
  78.         if (N_KIND(index) == as_simple_name && n != (Symbol)0 && is_type(n))
  79.             /* In the case of a slice, */
  80.             N_PTYPES(index) = set_new1((char *)TYPE_OF(n));
  81.             /* may be a type mark.*/
  82.         else
  83.             resolve1(index);
  84.     ENDFORTUP(ft1);
  85. #ifdef TBSN
  86.     if (cdebug2 > 3) TO_ERRFILE('index_list ' + str index_list);
  87. #endif
  88.     /* Now select those array types that are compatible with given indices.*/
  89.     FORSET(a_t = (Symbol), types, fs1);
  90.         t = a_t;
  91.         if (is_access(t)) {
  92.             if (is_fully_private(t)) {
  93.                 /* Cannot dereference an access to fully private type.*/
  94.                 if (set_size(array_types) == 1) {
  95.                     premature_access(t, a_expn);
  96.                     return set_new(0);
  97.                 }
  98.                 else
  99.                     continue;
  100.             }
  101.             else t = (Symbol) designated_type(t);
  102.         }
  103. #ifdef TBSN
  104.         if (cdebug2 > 3) {
  105.             TO_ERRFILE('type ' + str t);
  106.             TO_ERRFILE('# dims t ' + str no_dimensions(t));
  107.         }
  108. #endif
  109.         /* Discard incompatible array types */
  110.         if (!is_array(t) || no_dimensions(t) != tup_size(index_list))
  111.             continue;
  112.  
  113.         /* Now verify all indices in turn.*/
  114.         forall = TRUE;
  115.         FORTUPI(index = (Node), index_list, i, ft1);
  116.             exists = FALSE;
  117.             FORSET(i_t = (Symbol), N_PTYPES(index), fs2);
  118.                 if (compatible_types(i_t, (Symbol) index_types(t)[i])) {
  119.                     exists = TRUE;
  120.                     break;
  121.                 }
  122.             ENDFORSET(fs2);
  123.             if (exists == FALSE) {
  124.                 forall = FALSE;
  125.                 break;
  126.             }
  127.         ENDFORTUP(ft1);
  128.         if (forall)
  129.             /* a valid array type*/
  130.             array_types = set_with(array_types, (char *)a_t);
  131.     ENDFORSET(fs1);
  132. #ifdef TBSN
  133.     if (cdebug2 > 3) TO_ERRFILE('valid_array_expn ' + str array_types);
  134. #endif
  135.  
  136.     N_PTYPES(a_expn) = array_types;
  137.     rset = set_new(0);
  138.     FORSET(a_t = (Symbol), array_types, fs1);
  139.         if (is_access(a_t))
  140.             rset = set_with(rset, (char *) designated_type(a_t));
  141.         else
  142.             rset = set_with(rset, (char *) a_t);
  143.     ENDFORSET(fs1);
  144.     return rset;
  145. }
  146.  
  147. Symbol complete_array_expn(Node expn, Symbol c_type)  /*;complete_array_expn*/
  148. {
  149.     /* Called to complete the validation of an index or slice expression. The
  150.      * context type is the element    type for indexing, and the array type for
  151.      * slicing . The array expression may yield an access type, in which case
  152.      * a dereference operation is emitted now.
  153.      */
  154.  
  155.     Node    a_expn, index_list, a_node;
  156.     Set        array_types;
  157.     Symbol    array_type, a_t, t, c, access_type;
  158.     Forset    fs1;
  159.  
  160.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : complete_array_expn");
  161.  
  162.     a_expn = N_AST1(expn);
  163.     index_list = N_AST2(expn);
  164.     array_types = N_PTYPES(a_expn);
  165.     array_type = (Symbol)0;
  166.  
  167.     /* Iterate over array types to find unique one satisfying context.*/
  168.  
  169.     FORSET(a_t = (Symbol), array_types, fs1);
  170.         t = (is_access(a_t)) ? (Symbol)designated_type(a_t): a_t;
  171.         c = (N_KIND(expn) == as_slice) ? t: (Symbol) (component_type(t));
  172.         if (compatible_types(c_type, c)) {
  173.             if (array_type == (Symbol)0) {    /* One match found.*/
  174.                 array_type = t;
  175.                 access_type = a_t; /* Maybe an access.*/
  176.             }
  177.             else {
  178.                 /* If it is ambiguous, then it must an overloaded function*/
  179.                 /* that returns (an access to) an array.*/
  180.                 array_type = symbol_any;
  181.             }
  182.         }
  183.     ENDFORSET(fs1);
  184.     if (array_type == symbol_any) {
  185.         remove_conversions(a_expn);        /* last chance. */
  186.         if (set_size(N_PTYPES(a_expn)) == 1) {
  187.             array_type = (Symbol) set_arb(N_PTYPES(expn));
  188.             access_type = array_type;
  189.             if (is_access(array_type))
  190.                 array_type = (Symbol) designated_type(access_type);
  191.         }
  192.         else {        /* still ambiguous */
  193.             /* SETL sends {'indexing'}, in C, send {'any'} */
  194.             type_error(set_new1((char *) symbol_any), c_type, 
  195.               set_size(N_PTYPES(a_expn)), expn);
  196.         }
  197.     }
  198.     if (array_type == (Symbol)0) {
  199.         /* SETL sends {'indexing'}, in C, send {'any'} */
  200.         type_error(set_new1((char *) symbol_any), c_type, 
  201.           set_size(N_PTYPES(a_expn)), expn);
  202.         array_type = symbol_any;
  203.     }
  204.  
  205.     if (array_type != access_type) {           /* Insert dereference. */
  206.         a_node = copy_node(a_expn);
  207.         N_KIND(a_expn) = as_all;
  208.         N_AST1(a_expn) = a_node;
  209.         N_AST2(a_expn) = N_AST3(a_expn) = N_AST4(a_expn) = (Node) 0;
  210.         N_PTYPES(a_expn) = set_new1((char *) array_type);
  211.     }
  212.     resolve2(a_expn, array_type);            /* and resolve. */
  213.  
  214.     return array_type;
  215. }
  216.  
  217. void valid_selected_expn(Node expn) /*;valid_selected_expn*/
  218. {
  219.     /* Use the name of the selector to determine the possible types of obj,
  220.      * which may be a function returning (an access to) a record or task type
  221.      * The possible types of the expression are those of the selected comps.
  222.      */
  223.  
  224.     Node    obj, s_node;
  225.     Set types1, valid_t;
  226.     Symbol    o_t, t, comp;
  227.     char    *selector;
  228.     Forset    fs1;
  229.     Declaredmap    decls;
  230.  
  231.     obj = N_AST1(expn);
  232.     s_node = N_AST2(expn);
  233.     selector = N_VAL(s_node);
  234.     resolve1(obj);
  235.     types1 = N_PTYPES(obj);
  236.     valid_t = set_new(0);
  237.  
  238.     FORSET( o_t = (Symbol), types1, fs1);
  239.         t = o_t;
  240.         if (is_access(o_t))t = (Symbol) designated_type(o_t);
  241.         if (is_record(t))
  242.             decls = (Declaredmap) (declared_components(base_type(t)));
  243.         else if (is_task_type(t))
  244.             decls = DECLARED(t);
  245.         else continue;
  246.  
  247.         comp = dcl_get(decls, selector);
  248.         if (comp != (Symbol)0) {
  249.             if (is_access(o_t) && is_fully_private(o_t)
  250.               && NATURE(comp) != na_discriminant) { /*$ Can't dereference.*/
  251.                 if (set_size(types1) == 1) {
  252.                     premature_access(o_t, obj);
  253.                     return;
  254.                 }
  255.                 else continue;
  256.             }
  257.             else
  258.                 valid_t = set_with(valid_t, (char *) TYPE_OF(comp));
  259.         }
  260.     ENDFORSET(fs1);
  261.  
  262.     if (set_size(valid_t) == 0)
  263.         pass1_error("invalid selector name", "4.1.3", s_node);
  264.     N_PTYPES(expn) = valid_t;
  265. }
  266.  
  267. Symbol complete_selected_expn(Node expn, Symbol c_type)
  268.                                                     /*;complete_selected_expn*/
  269. {
  270.     /* Complete the resolution of a selected component  expression, by
  271.      * choosing the one that yields the context_type. If the type of the
  272.      * object selected from is an access type, emit a dereference.
  273.      */
  274.  
  275.     Node    obj, s_node, acc_obj;
  276.     Set types1;
  277.     Symbol    comp_t, o_t, t, comp, obj_t, c;
  278.     int        out_c;
  279.     Forset    fs1;
  280.     char    *selector;
  281.     Declaredmap    decls;
  282.  
  283.     obj = N_AST1(expn);
  284.     s_node = N_AST2(expn);
  285.     selector = N_VAL(s_node);
  286.     types1 = N_PTYPES(obj);
  287.     comp_t = (Symbol)0;
  288.  
  289.     FORSET( o_t = (Symbol), types1, fs1);
  290.         t = (is_access(o_t)) ? (Symbol) designated_type(o_t): o_t;
  291.     
  292.         if (is_record(t))
  293.             decls = (Declaredmap) declared_components(base_type(t));
  294.         else if (is_task_type(t))
  295.             decls = DECLARED(t);
  296.  
  297.         c = dcl_get(decls, selector);
  298.         if (c != (Symbol)0 && compatible_types(TYPE_OF(c), c_type)) {
  299.             comp = c;
  300.             if (comp_t == (Symbol)0) {
  301.                 comp_t = TYPE_OF(comp);        /* Found a match*/
  302.                 N_UNQ(s_node) = comp;
  303.                 obj_t = o_t;
  304.             }
  305.             else             /* ambiguous call to some*/
  306.                 obj_t = symbol_any;
  307.         }
  308.  
  309.     ENDFORSET(fs1); 
  310.  
  311.     if (obj_t == symbol_any) {
  312.         remove_conversions(obj);            /* last hope. */
  313.         if (set_size(N_PTYPES(obj)) != 1) {
  314. #ifdef TBSL
  315.             type_error(set_new1(symbol_selection), (Symbol)0, 
  316.               set_size(N_PTYPES(obj)), expn);
  317. #endif
  318.             return (Symbol)0;
  319.         }
  320.         else
  321.             obj_t = (Symbol) set_arb(N_PTYPES(obj));
  322.     }
  323.  
  324.     out_c = out_context;
  325.     /* This is a valid context for the use of an out parameter, if 
  326.      * it is an assigment to a component of it, or if it is a reading
  327.      * of a discriminant.
  328.      */
  329.     out_context = (out_c || NATURE(comp) == na_discriminant) ? TRUE:FALSE;
  330.  
  331.     if (is_access(obj_t)) {
  332.         obj_t = (Symbol) designated_type(obj_t);
  333.         /* Introduce explicit dereference. */
  334.         acc_obj = copy_node(obj);
  335.         N_KIND(obj) = as_all;
  336.         N_AST2(obj) = N_AST3(obj) = N_AST4(obj) = (Node) 0;
  337.         N_AST1(obj) = acc_obj;
  338.         N_PTYPES(obj) = set_new1((char *)obj_t);
  339.     }
  340.  
  341.     resolve2(obj, obj_t);
  342.     out_context = out_c;
  343.  
  344.     return comp_t;
  345. }
  346.  
  347. static Triplet *is_partition(Tuple choice_tuple, int choice_tuple_size,
  348.   int exist_other_choice)                                     /*;is_partition*/
  349. {
  350.  
  351.     /* Checks if the ranges of the choice_nodes in a named array aggregate form 
  352.      * a partition.
  353.      * For example: (1|2|4 =>2, 5..10 =>3, 3 =>2, NUM => 4) where you can find
  354.      * simple_choices, a range_choice and a choice_unresolved. This will be a
  355.      * partition if the type_mark NUM is disjoint with {1..10} assuming that 
  356.      * the bounds of the array are (1..NUM'LAST).  A range such as 7..4 is a
  357.      * null range. It is permitted only if alone in the array aggregate.
  358.      * This function returns a pointer to a Triplet. This Triplet gives the
  359.      * final range of the aggregate. Complete_a_aggregate checks after whether
  360.      * the range of the aggregate is the same than the range of the array. It
  361.      * uses the system call 'qsort' to sort the ranges by their lower bound
  362.      * and then uses this sorted list to verify that it is a partition.
  363.      */
  364.  
  365.     int        lbd, ubd = 0, ubd_save;
  366.     Triplet    *i_trip;
  367.     Node       choice;
  368.     int        i;
  369.  
  370.     if (choice_tuple_size != 0) {
  371.  
  372.         /*  1.  sort the set of choices giving a tuple  */
  373.  
  374.         choice_tuple = sort_case(choice_tuple);
  375.  
  376.         /*  2.  pass over choice_tuple checking that:
  377.          *        - there are only legal null ranges
  378.          *        - there are no overlapping ranges
  379.          *        - if the array aggregate does not have an others
  380.          *          then there are no missing associations
  381.          */
  382.  
  383.         for (i = 1; (i <= choice_tuple_size); i++) {
  384.             ubd_save = ubd;
  385.             lbd = ((Triplet *) choice_tuple[i])->inf;
  386.             ubd = ((Triplet *) choice_tuple[i])->sup;
  387.             choice = ((Triplet *) choice_tuple[i])->choice_node;
  388.  
  389.             /*  1.  Check for a null range. */
  390.             if ((lbd > ubd) && (choice_tuple_size > 1 || exist_other_choice)) {
  391. #ifdef ERRNUM
  392.                 errmsgn(284, 285, choice);
  393. #else
  394.                 errmsg(
  395.                   "A null range in array aggregate must be the only choice",
  396.                   "4.3.2.(3)", choice);
  397. #endif
  398.                 prev_error_message = 1;
  399.                 return (Triplet *)0;
  400.             }
  401.  
  402.             /*  2.  Check that the ranges do not overlap  */
  403.  
  404.             else if ((lbd <= ubd_save) && (i > 1)) {
  405. #ifdef ERRNUM
  406.                 errmsgn(286, 287, choice);
  407. #else
  408.                 errmsg(
  409.                   "Component is not allowed to be specified more than once",
  410.                   "4.3.(6)", choice);
  411. #endif
  412.                 prev_error_message = 1;
  413.                 return (Triplet *)0;
  414.             }
  415.  
  416.             /*  3.  Check that the intersection between the ranges is not null*/
  417.  
  418.             else if ((i > 1) && (!exist_other_choice) && (lbd != ubd_save+1)) {
  419. #ifdef ERRNUM
  420.                 errmsgn(288, 287, choice);
  421. #else
  422.                 errmsg("Missing association in array aggregate", "4.3.(6)",
  423.                   choice);
  424. #endif
  425.                 prev_error_message = 1;
  426.                 return (Triplet *)0;
  427.             }
  428.         }
  429.  
  430.         i_trip = triplet_new();
  431.         i_trip->inf = ((Triplet *) choice_tuple[1])->inf;
  432.         i_trip->sup = ((Triplet *) choice_tuple[choice_tuple_size])->sup;
  433.         return (i_trip);
  434.     }
  435. }
  436.  
  437. static Tuple sort_case(Tuple tuple_to_sort)                        /*;sort_case*/
  438. {
  439.     /*  This function sorts a tuple of triples based on the value of the
  440.      *  first element
  441.      */
  442.  
  443.     qsort((char *) &tuple_to_sort[1], tup_size(tuple_to_sort), sizeof (char *),
  444.       (int (*)(const void *, const void *))tcompar);
  445.     return tuple_to_sort;
  446. }
  447.  
  448. static int tcompar(Triplet **ptup1, Triplet **ptup2)            /*;tcompar*/
  449. {
  450.     Triplet  *tup1, *tup2;
  451.     int   n1, n2;
  452.  
  453.     tup1 = *ptup1;                 
  454.     tup2 = *ptup2;
  455.     n1 = (int) (tup1->inf);    
  456.     n2 = (int) (tup2->inf);
  457.     if (n1 == n2) return 0;
  458.     else if (n1 < n2) return -1;
  459.     else return 1;
  460. }
  461.  
  462. static int abs_val(int x)                                     /*;abs_val*/
  463. {
  464.     return (x >= 0) ? x : -x;
  465. }
  466.  
  467. void complete_aggregate(Symbol agg_type, Node expn)         /*;complete_aggregate*/
  468. {
  469.     /* Given the context type, resolve the aggregate components. For an array
  470.      * type we  pass index    and component  types separately     to the recursive
  471.      * routine complete_a_aggregate.  For record types  only the base type is
  472.      * needed here. Any required constraints are imposed in resolve2.
  473.      */
  474.  
  475.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : complete_aggregate");
  476.  
  477.     if (is_limited_type(agg_type)) {
  478. #ifdef ERRNUM
  479.         id_errmsgn(289, agg_type, 34, expn);
  480. #else
  481.         errmsg_id("aggregates not available for limited type %", agg_type,
  482.           "7.4.4", expn);
  483. #endif
  484.     }
  485.  
  486.     if (is_array(agg_type)) {
  487.         /* if the context allows sliding, the bounds of the aggregate need
  488.          * only be verified against the unconstrained type.              
  489.          */
  490.         if (full_others)
  491.             complete_a_aggregate(index_types(agg_type), index_types(agg_type),
  492.               component_type(agg_type), can_constrain(agg_type), expn);
  493.         else
  494.             complete_a_aggregate(index_types(agg_type),
  495.               index_types(TYPE_OF(agg_type)), component_type(agg_type),
  496.               can_constrain(agg_type), expn);
  497.     }
  498.     else if (is_record(agg_type))
  499.         complete_r_aggregate(base_type(agg_type), expn);
  500.     else {
  501. #ifdef ERRNUM
  502.         errmsgn(290, 10, expn);
  503. #else
  504.         errmsg("Invalid context for aggregate", "none", expn);
  505. #endif
  506.     }
  507. }
  508.  
  509. static void complete_a_aggregate(Tuple indices, Tuple base_indices,
  510.   Symbol comp_type, int is_unc, Node expn)            /*;complete_a_aggregate*/
  511. {
  512.     /* Complete processing of an array aggregate. The tree is normalized as
  513.      * follows:
  514.      *     N_KIND = as_array_aggregate
  515.      *     N_AST = [list_node, others_node]
  516.      * where list_node has two entries:
  517.      *     N_AST = [pos_list, nam_list]
  518.      * The first two are list nodes. The elements of N_LIST(nam_list) are
  519.      * pairs [choice_list, expression].  The N_KIND of choice nodes are 
  520.      * as_simple_choice and as_range_choice.  A simple_choice includes a 
  521.      * type name specifiying a range.
  522.      */
  523.  
  524.     Tuple    arg_list, pos_list, nam_list, tup, b_itup, itup;
  525.     Node    others_node, last_arg, choice_list, c_expr, lexpn;
  526.     Node    arg, i_expr, range_constraint, choice, pos_node, nam_node;
  527.     Symbol    type_mark, indxt, b_indxt;
  528.     Fortup    ft1, ft2;
  529.     int    i, n, nn;
  530.     int     c_ind, exist_other_choice, lbd, ubd, lbd_val, ubd_val;
  531.     int     static_test, choice_tuple_size;
  532.     int    raises;
  533.     Tuple   choice_tuple;
  534.     Triplet    *aggr_range;
  535.     Node    lw_bd, hg_bd, lo_bd, up_bd, simple_expr1, simple_expr2;
  536.     char    *nchoice;
  537.  
  538.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : complete_a_aggregate");
  539.  
  540.     arg_list = N_LIST(expn);
  541.     b_indxt = (Symbol) base_indices[1];
  542.     indxt = (Symbol) indices[1];
  543.     others_node = OPT_NODE;
  544.     pos_list = tup_new(0);
  545.     nam_list = tup_new(0);
  546.     choice_tuple_size = 0;
  547.     static_test = 1;
  548.     c_ind = 1;
  549.     exist_other_choice = 0;
  550.     prev_error_message = 0;
  551.     raises = FALSE;
  552.  
  553.     /* STEP 1.
  554.      *   Remove the OTHERS choice from the arggregate list if it is the last
  555.      *   component and place in -others_choice-. Otherwise if it appears
  556.      *   elsewhere in the aggregate it will be noted as a error later.
  557.      */
  558.  
  559.     last_arg = (Node) arg_list[tup_size(arg_list)];
  560.     if (N_KIND(last_arg) == as_choice_list) {
  561.         choice_list = N_AST1(last_arg);
  562.         c_expr = N_AST2(last_arg);
  563.         tup = N_LIST(choice_list);
  564.         choice = (Node) tup[1];
  565.  
  566.         if (N_KIND(choice) == as_others_choice) {
  567.             exist_other_choice = 1;
  568.             others_node = c_expr;
  569.  
  570.             if (is_unc || (!is_static_subtype(indxt) && tup_size(arg_list)>1)) {
  571. #ifdef ERRNUM
  572.                 errmsgn(291, 292, last_arg);
  573. #else
  574.                 errmsg("OTHERS choice not allowed in this context", "4.3.2",
  575.                   last_arg);
  576. #endif
  577.             }    /* process anyway*/
  578.  
  579.             tup_frome(arg_list);
  580.             resolve1(c_expr);
  581.             n = tup_size(base_indices);
  582.             nn = tup_size(indices);
  583.             if (nn > 0 && n > 0) {
  584.                 b_itup = tup_new(n-1);
  585.                 itup = tup_new(n-1);
  586.                 for (i = 1; i < n; i++)
  587.                     b_itup[i] = base_indices[i+1];
  588.                 for (i = 1; i < nn; i++)
  589.                     itup[i] = indices[i+1];
  590.                 complete_component(itup, b_itup, comp_type, is_unc, c_expr);
  591.                 raises = raises || (N_KIND(c_expr) == as_raise);
  592.             }
  593.         }
  594.     }
  595.  
  596.     /* STEP 2.
  597.      *   After any others clause has been processed, process the named and
  598.      *   positional associations
  599.      */
  600.  
  601.     FORTUP(arg = (Node), arg_list, ft1);
  602.         if (N_KIND(arg) == as_choice_list) {
  603.             /* STEP 2a.
  604.              *   Process named association choice list 
  605.              */
  606.             choice_list = N_AST1(arg);
  607.             c_expr = N_AST2(arg);
  608.             resolve1(c_expr);
  609.             n = tup_size(base_indices);
  610.             nn = tup_size(indices);
  611.             if (nn > 0 && n > 0) {
  612.                 b_itup = tup_new(n-1);
  613.                 itup = tup_new(n-1);
  614.                 for (i = 1; i < n; i++)
  615.                     b_itup[i] = base_indices[i+1];
  616.                 for (i = 1; i < nn; i++)
  617.                     itup[i] = indices[i+1];
  618.                 complete_component(itup, b_itup, comp_type, is_unc, c_expr);
  619.                 raises = raises || (N_KIND(c_expr) == as_raise);
  620.             }
  621.             else
  622.                 chaos("complete_a_aggregate - indices null");
  623.             /* STEP 2b.
  624.              *   Process each choice in the choice list
  625.              */
  626.             FORTUP(choice = (Node), N_LIST(choice_list), ft2);
  627.                 n = -1;
  628.                 if (N_KIND(choice) == as_choice_unresolved) {
  629.                     /* Case:  choice_unresolved:
  630.                      *     If the index expression is an identifier, it must be
  631.                      *     a type name or an object.
  632.                      */
  633.                     i_expr = N_AST1(choice);
  634.                     find_old(i_expr);
  635.                     type_mark = N_UNQ(i_expr);
  636.                     if (is_type(type_mark)) {
  637.                         /* Subcase: type type_mark of choice_unresolved
  638.                          *   check that it is either the only choice -or- is
  639.                          *   static...
  640.                          *     set the N_KIND to a as_simple_name
  641.                          *     check that the type_mark is compatible with
  642.                          *     the base index type 
  643.                          */
  644.                         tup = SIGNATURE(type_mark);
  645.                         lo_bd = (Node) tup[2];
  646.                         up_bd = (Node) tup[3];
  647.                         if ((!is_static_expr(lo_bd))||(!is_static_expr(up_bd))){
  648.                             if ((tup_size(arg_list)>1) || exist_other_choice) {
  649.                                 errmsg(
  650.     "Non static choice in array aggregate must be the only choice",
  651.     "4.3.2.(3)", choice); 
  652.                             }
  653.                             static_test = 0;
  654.                         }
  655.                         else {
  656.                             lbd_val = INTV((Const) N_VAL(lo_bd));
  657.                             ubd_val = INTV((Const) N_VAL(up_bd));
  658.                         }
  659.                         N_KIND(choice) = as_simple_name;
  660.                         nchoice = N_VAL(choice); /* preserve N_VAL */
  661.                         N_AST1(choice) = (Node)0;
  662.                         N_AST2(choice) = (Node)0;
  663.                         N_AST3(choice) = (Node)0;
  664.                         N_AST4(choice) = (Node)0;
  665.                         N_UNQ(choice) = type_mark;
  666.                         N_VAL(choice) = nchoice; /* preserve N_VAL */
  667.                         if (!compatible_types(type_mark, b_indxt)) {
  668. #ifdef ERRNUM
  669.                             errmsgn(293, 294, choice);
  670. #else
  671.                             errmsg("invalid type mark in array aggregate",
  672.                               "4.3", choice);
  673. #endif
  674.                             return;
  675.                         }
  676.                     }
  677.                     else { /* single association*/
  678.                         /* Subcase: simple_choice of choice_unresolved
  679.                          *     this is a single association
  680.                          *     set the N_KIND to a as_simple_name check that
  681.                          *     it is either the only choice -or- is static...
  682.                          */
  683.                         N_KIND(choice) = as_simple_choice;
  684.                         i_expr = N_AST1(choice);
  685.                         check_type(base_type(b_indxt), i_expr);
  686.                         if (N_TYPE(i_expr) == symbol_any)
  687.                             static_test = 0;
  688.                         else if (!is_static_expr(i_expr)) {
  689.                             if ((tup_size(arg_list)>1) || exist_other_choice) {
  690. #ifdef ERRNUM
  691.                                 errmsgn(295, 285, choice);
  692. #else
  693.                                 errmsg(
  694.     "Non static choice in array aggregate must be the only choice", "4.3.2.(3)",
  695.     choice);
  696. #endif
  697.                             }
  698.                             static_test = 0;
  699.                         }
  700.                         else {
  701.                             lbd_val = INTV((Const) N_VAL(i_expr));
  702.                             ubd_val = INTV((Const) N_VAL(i_expr));
  703.                         }
  704.                     }
  705.                 }
  706.                 /* Case: as_simple_choice
  707.                  *   The association is known to be a simple expression.
  708.                  *     check that the type of the expression 
  709.                  *     check that it is either the only choice -or- is static...
  710.                  */
  711.                 else if (N_KIND(choice) == as_simple_choice) {
  712.                     i_expr = N_AST1(choice);
  713.                     adasem(i_expr);
  714.                     check_type(base_type(b_indxt), i_expr);
  715.                     if (N_TYPE(i_expr) == symbol_any)
  716.                         static_test = 0;
  717.                     else if (!is_static_expr(i_expr)) {
  718.                         if ((tup_size(arg_list) > 1) || exist_other_choice)   {
  719. #ifdef ERRNUM
  720.                             errmsgn(295, 285, choice);
  721. #else
  722.                             errmsg(
  723.     "Non static choice in array aggregate must be the only choice",
  724.     "4.3.2.(3)", choice);
  725. #endif
  726.                         }
  727.                         static_test = 0;
  728.                     }
  729.                     else {
  730.                         lbd_val = INTV((Const) N_VAL(i_expr));
  731.                         ubd_val = INTV((Const) N_VAL(i_expr));
  732.                     }
  733.                 }
  734.                 /* Case: range_choice
  735.                  */
  736.                 else if (N_KIND(choice) == as_range_choice) {
  737.                     i_expr = N_AST1(choice);
  738.                     check_type(b_indxt, i_expr);
  739.                     if (N_KIND(i_expr) == as_subtype) {
  740.                         /* Subcase: expression is subtype in range_choice
  741.                          *   Extract the constraint itself is static, reformat
  742.                          *   choice as range else check that it is the only
  743.                          *   choice
  744.                          */
  745.                         range_constraint = N_AST2(i_expr);
  746.                         copy_attributes(range_constraint, choice);
  747.                         simple_expr1 = N_AST1(range_constraint);
  748.                         simple_expr2 = N_AST2(range_constraint);
  749.                         if (N_TYPE(i_expr) == symbol_any)
  750.                             static_test = 0;
  751.                         else if ((!is_static_expr(simple_expr1))
  752.                           || (!is_static_expr(simple_expr2))) {
  753.                             if ((tup_size(arg_list) > 1) || exist_other_choice){
  754. #ifdef ERRNUM
  755.                                 errmsgn(295, 285, choice);
  756. #else
  757.                                 errmsg(
  758.     "Non static choice in array aggregate must be the only choice",
  759.     "4.3.2.(3)", choice);
  760. #endif
  761.                             }
  762.                             static_test = 0;
  763.                         }
  764.                         else {
  765.                             lbd_val = INTV((Const) N_VAL(simple_expr1));
  766.                             ubd_val = INTV((Const) N_VAL(simple_expr2));
  767.                         }
  768.                     }
  769.                     else { /*attribute RANGE.*/
  770.                         /* Subcase: attribute range subtype in range_choice
  771.                          *        this means that it is an attrtibute range
  772.                          */
  773.                         static_test = 0;
  774.                     }
  775.                 }
  776.                 /* Case: others choice (illegal at this point)
  777.                  */
  778.  
  779.                 else if (N_KIND(choice) == as_others_choice)  {
  780. #ifdef ERRNUM
  781.                     errmsgn(296, 294, choice);
  782. #else
  783.                     errmsg("OTHERS must be the last aggregate component",
  784.                       "4.3", choice);
  785. #endif
  786.                     return;
  787.  
  788.                 }
  789.                 /* STEP 2c.
  790.                  *   After processing the choice if it is static then add to
  791.                  *   choice list to be tested with is_partition
  792.                  */
  793.                 if (static_test) {
  794.                     aggr_range = triplet_new();
  795.                     aggr_range->inf = lbd_val;  /*bounds and node of the curr */
  796.                     aggr_range->sup = ubd_val;  /*choice_node for is_partition*/
  797.                     aggr_range->choice_node = choice;
  798.                     if (c_ind == 1)
  799.                         choice_tuple = tup_new1((char *) aggr_range);
  800.                     else
  801.                         choice_tuple =tup_with(choice_tuple,(char *)aggr_range);
  802.                 }
  803.                 c_ind++;
  804.             ENDFORTUP(ft2);   /* choice within a named choice list */
  805.  
  806.             /* STEP 2d.
  807.              *    Add the choice list to the tuple of named associations
  808.              */
  809.             nam_list = tup_with(nam_list, (char *) arg);
  810.         }
  811.  
  812.         /* STEP 3.
  813.          *   Process positional components...
  814.          */
  815.         else { /* Positional component. */
  816.             resolve1(arg);
  817.             n = tup_size(base_indices);
  818.             nn = tup_size(indices);
  819.             if (nn > 0 && n > 0) {
  820.                 b_itup = tup_new(n-1);
  821.                 itup = tup_new(n-1);
  822.                 for (i = 1; i < n; i++)
  823.                     b_itup[i] = base_indices[i+1];
  824.                 for (i = 1; i < nn; i++)
  825.                     itup[i] = indices[i+1];
  826.                 complete_component(itup, b_itup, comp_type, is_unc, arg);
  827.                 raises = raises || (N_KIND(arg) == as_raise);
  828.             }
  829.             else chaos("complete_a_aggregate - indices null");
  830.             pos_list = tup_with(pos_list, (char *) arg);
  831.         }
  832.     ENDFORTUP(ft1); /* end of processing the choice lists  */
  833.  
  834.     /* STEP 4.
  835.      *   Perform the final checks.  
  836.      *     A. Check that either the name list or the position list is null
  837.      *     B. Check for valid context for Others choice
  838.      */
  839.     if (tup_size(pos_list) > 0 && tup_size(nam_list) > 0) {
  840. #ifdef ERRNUM
  841.         l_errmsgn(297, 298, 292, expn);
  842. #else
  843.         errmsg_l("In a positional aggregate only named association ",
  844.           "allowed is OTHERS", "4.3.2", expn);
  845. #endif
  846.         return;
  847.     }
  848.     else if (others_node != OPT_NODE && !full_others && tup_size(nam_list) !=0){
  849. #ifdef ERRNUM
  850.         errmsgn(299, 300, others_node);
  851. #else
  852.         errmsg("Invalid context for OTHERS and named associations",
  853.           "4.3.2(6)", others_node);
  854. #endif
  855.         return;
  856.     }
  857.  
  858.     tup = SIGNATURE(indxt);   /*range of the array.*/
  859.     lw_bd = (Node) tup[2];
  860.     hg_bd = (Node) tup[3];
  861.     /* STEP 5.
  862.      *   Perform check is it is static and named
  863.      *   If it is a partition then check:
  864.      *     A.  If the range is out of bounds (base index) considering sliding
  865.      *     B.  if the size of the choice range is less than the index range
  866.      *     C.  if the size of the choice range is greater that the index range
  867.      *     D.  if the choice range is null and the index range is not
  868.      */
  869.     if (n == -1 && static_test)   {
  870.         choice_tuple_size = tup_size(choice_tuple);
  871.         aggr_range = is_partition(choice_tuple, choice_tuple_size,
  872.           exist_other_choice);
  873.  
  874.         if (!prev_error_message && !exist_other_choice)  {
  875.             lbd = aggr_range->inf;
  876.             ubd = aggr_range->sup;
  877.             tup = SIGNATURE(b_indxt); /*range of the indices.*/
  878.             lo_bd = (Node) tup[2];
  879.             up_bd = (Node) tup[3];
  880.             if ((is_static_expr(lo_bd)) && (is_static_expr(up_bd)))  {
  881.                 lbd_val = INTV((Const) N_VAL(lo_bd));
  882.                 ubd_val = INTV((Const) N_VAL(up_bd));
  883.  
  884.                 /* Check A */
  885.                 if ((lbd_val > lbd || ubd_val < ubd)
  886.                   && (ubd_val > lbd_val && ubd > lbd)   /*Non-null range*/
  887.                   && full_others)   {
  888.                     /* Does not check anything if the subtype_range or the
  889.                      * aggregate_range is null, according to test c43206a.
  890.                      */
  891.                     raises = TRUE;
  892.                 }
  893.             }
  894.             if (!is_unc) {
  895.                 if ((is_static_expr(lw_bd)) && (is_static_expr(hg_bd)))  {
  896.                     lbd_val = INTV((Const) N_VAL(lw_bd));
  897.                     ubd_val = INTV((Const) N_VAL(hg_bd));
  898.                     /* TBSL : ubd_val-lbd_val may be superior to INTEGER'LAST.
  899.                      * Use multiprecision.
  900.                      */
  901.                     /* Check B */
  902.                     if ((ubd_val > lbd_val && ubd > lbd)   /*Non-null range*/
  903.                       && (abs_val(ubd_val - lbd_val) < abs_val(ubd - lbd)))
  904.                         raises = TRUE;
  905.                     /* TBSL : ubd_val-lbd_val may be superior to INTEGER'LAST.
  906.                      * Use multiprecision.
  907.                      */
  908.                     /* Check C */
  909.                     else if ((ubd_val > lbd_val && ubd > lbd) /*Non-null range*/
  910.                       && (abs_val(ubd_val - lbd_val) > abs_val(ubd - lbd))) {
  911.                         /* CONSTRAINT_ERROR may be raised according to test
  912.                          * c48009f instead of:
  913.                          * #ifdef ERRNUM
  914.                            *     errmsgn(288, 287, expn);
  915.                          * #else
  916.                            *     errmsg("Missing association in array aggregate",
  917.                          *       "4.3.(6)", expn);
  918.                          * #endif
  919.                          */
  920.                         raises = TRUE;
  921.                     }
  922.                     /* Check D */
  923.                     else if (ubd_val < lbd_val && ubd > lbd) {
  924.                         raises = TRUE;
  925.                     }
  926.                 }
  927.             }
  928.         }
  929.     }
  930.     /* STEP 6.
  931.      *   Perform check is it is position, not others and unconstrained
  932.      */
  933.     if (n != -1 && !is_unc && !exist_other_choice) { /*Positional components*/
  934.         if ((is_static_expr(lw_bd)) && (is_static_expr(hg_bd)))  {
  935.             lbd_val = INTV((Const) N_VAL(lw_bd));
  936.             ubd_val = INTV((Const) N_VAL(hg_bd));
  937.             /* TBSL : ubd_val-lbd_val may be superior to INTEGER'LAST.
  938.              * Use multiprecision.
  939.              */
  940.             if (tup_size(pos_list) != abs_val(ubd_val-lbd_val) + 1) {
  941.                 raises = TRUE;
  942.             }
  943.         }
  944.     }
  945.  
  946.     /* STEP 7. 
  947.      *   Proccess an others choice by itself by converted into a named
  948.      *   association
  949.      */
  950.     if (tup_size(pos_list) == 0 && tup_size(nam_list) == 0) {
  951.         if ((N_KIND(lw_bd) == as_ivalue || N_KIND(lw_bd) == as_discr_ref)
  952.           &&  (N_KIND(hg_bd) == as_ivalue || N_KIND(hg_bd) == as_discr_ref)) {
  953.             choice = node_new(as_range);
  954.             N_AST1(choice) = copy_tree(lw_bd);
  955.             N_AST2(choice) = copy_tree(hg_bd);
  956.             arg = node_new(as_choice_list);
  957.             N_AST1(arg) = node_new(as_list);
  958.             N_LIST(N_AST1(arg)) = tup_new1( (char *)choice);
  959.             N_AST2(arg) = others_node;
  960.             nam_list = tup_new1( (char *)arg);
  961.             others_node = OPT_NODE;
  962.         }
  963.     }
  964.  
  965.     /* If any component or subaggregate raises constraint error, replace the
  966.      * whole aggregate by a raise node.
  967.      */
  968.     if (raises) {
  969.         create_raise(expn, symbol_constraint_error);
  970.         return;
  971.     }
  972.     /* STEP 8. 
  973.      *   Create the pos and name lists nodes
  974.      */
  975.     pos_node = node_new(as_list);
  976.     nam_node = node_new(as_list);
  977.     N_LIST(pos_node) = pos_list;
  978.     N_LIST(nam_node) = nam_list;
  979.  
  980.     N_KIND(expn) = as_array_aggregate;
  981.     N_UNQ(expn) = sym_new(na_void);
  982.     N_LIST(expn) = tup_new(0);    /* no further need for it.*/
  983.     lexpn = node_new(as_aggregate_list);
  984.     N_AST1(lexpn) = pos_node;
  985.     N_AST2(lexpn) = nam_node;
  986.     N_AST1(expn) = lexpn;
  987.     N_AST2(expn) = others_node;
  988.     N_AST4(expn) = (Node) 0;
  989. }
  990.  
  991. static void complete_component(Tuple indices, Tuple b_indices, Symbol comp_type,
  992.    int is_unc, Node expn)                                /*;complete_component*/
  993. {
  994.     /* Complete the     resolution of a component of  an array aggregate. If it
  995.      * is a multidimensional aggregate, the component itself is an array and
  996.      * a recursive    call is made with the remaining indices. String literals
  997.      * are handled in their own routine.
  998.      */
  999.  
  1000.     Node    expn2;
  1001.  
  1002.     if (cdebug2 > 3) TO_ERRFILE("AT PROC complete_component");
  1003.  
  1004.     if (tup_size(b_indices) == 0)
  1005.         res2_check(expn, comp_type);
  1006.     else if (N_KIND(expn) == as_aggregate)
  1007.         complete_a_aggregate(indices, b_indices, comp_type, is_unc, expn);
  1008.     else if (N_KIND(expn) == as_string_literal) {
  1009.         if (tup_size(b_indices) != 1) {
  1010. #ifdef ERRNUM
  1011.             errmsgn(301, 292, expn);
  1012. #else
  1013.             errmsg("Invalid use of literal in aggregate", "4.3.2", expn);
  1014. #endif
  1015.             return;
  1016.         }
  1017.         complete_string_literal(expn, comp_type);
  1018.         N_TYPE(expn) = (Symbol) 0; /* clear as no type defined here */
  1019.     }
  1020.     else if (N_KIND(expn) == as_parenthesis) {
  1021.         /* Context of subaggregate is unconstrained, "others" choice is not*/
  1022.         /* allowed.*/
  1023.         expn2 = N_AST1(expn);
  1024.         complete_component(indices, b_indices, comp_type, TRUE, expn2);
  1025.     }
  1026.     else {
  1027. #ifdef ERRNUM
  1028.         errmsgn(302, 292, expn);
  1029. #else
  1030.         errmsg("Expect aggregate for component of multidimensional aggregate",
  1031.           "4.3.2", expn);
  1032. #endif
  1033.     }
  1034. }
  1035.  
  1036. void complete_string_literal(Node node, Symbol comp)
  1037.                                                 /*;complete_string_literal*/
  1038. {
  1039.     /* String literals can appear as aggregates for arrays of character type.
  1040.      * We have to verify that each character in the string is an  enumeration
  1041.      * literal for that type.
  1042.      */
  1043.  
  1044.     char    *strg, c, *lit;
  1045.     Tuple    arr, lit_map;
  1046.     Node    lo, hi;
  1047.     Symbol    sc;
  1048.     int        i, strglen, istr, ilitmap, v, exists, found;
  1049.  
  1050.     strg = N_VAL(node);
  1051.     sc = SCOPE_OF(comp);
  1052.     if (!tup_mem((char *)sc, open_scopes) && !tup_mem((char *)sc, used_mods)) {
  1053. #ifdef ERRNUM
  1054.         errmsgn(303, 304, node);
  1055. #else
  1056.         errmsg("characters in a string literal must be directly visible",
  1057.          "4.2(3)", node);
  1058. #endif
  1059.     }
  1060.  
  1061.     if (comp == symbol_character || comp == symbol_any) {
  1062.         /*arr := [abs c: c in strg];*/
  1063.         strglen = strlen(strg);
  1064.         arr = tup_new(strglen);
  1065.         for (i = 1; i <= strglen; i++)
  1066.             arr[i] = (char *) strg[i-1];
  1067.         N_VAL(node) = (char *) arr;
  1068.         N_KIND(node) = as_string_ivalue;
  1069.     }
  1070.     else {/* Some enumeration type. Use its literal map.*/
  1071.         if (NATURE(base_type(comp)) != na_enum) {
  1072. #ifdef ERRNUM
  1073.             errmsgn(305, 251, node);
  1074. #else
  1075.             errmsg("Component type of context is not a character type",
  1076.               "4.2", node);
  1077. #endif
  1078.             return;
  1079.         }
  1080.         lit_map = (Tuple) literal_map(base_type(comp));
  1081.         if (lit_map == (Tuple)0) lit_map = tup_new(0);
  1082.         /* arr := [lit_map('''' + c + '''') : c in strg]; */
  1083.         strglen = strlen(strg);
  1084.         arr = tup_new(strglen);
  1085.         lit = emalloct(4, "complete-string-literal");
  1086.         exists = FALSE;
  1087.         for (istr = 0; c = strg[istr]; istr++) {
  1088.             lit[0] = lit[2] = '\'';
  1089.             lit[1] = c;
  1090.             lit[3] = '\0';
  1091.             found = FALSE;
  1092.             for (ilitmap = 1; ilitmap < tup_size(lit_map); ilitmap += 2) {
  1093.                 if (streq(lit, lit_map[ilitmap])) {
  1094.                     arr[istr+1] = lit_map[ilitmap+1];
  1095.                     found = TRUE;
  1096.                     break;
  1097.                 }
  1098.             }
  1099.             if (!found)
  1100.                 exists = TRUE;
  1101.         }
  1102.         /* if exists c = strg(i) | arr(i) = om then */
  1103.         /*  Some characters are not in the component type. */
  1104.         if (exists) {
  1105.             create_raise(node, symbol_constraint_error);
  1106.             return;
  1107.         }
  1108.         else {
  1109.             /* The individual characters must be bounds-checked as any other
  1110.              * array component.
  1111.              */
  1112.             N_VAL(node) = (char *)arr;
  1113.             N_KIND(node) = as_string_ivalue;
  1114.             if (NATURE(comp) == na_subtype) {
  1115.                 lo = (Node) (SIGNATURE(comp))[2];
  1116.                 hi = (Node) (SIGNATURE(comp))[3];
  1117.                 if (is_static_expr(lo) && is_static_expr(hi)) {
  1118.                     /* and exists v in arr | v<N_VAL(lo) or v>N_VAL(hi) then */
  1119.                     for (istr = 1; istr <= strglen; istr++) {
  1120.                         v = (int) arr[istr];
  1121.                         if (v < ((Const)N_VAL(lo))->const_value.const_int
  1122.                           || v > ((Const)N_VAL(hi))->const_value.const_int) {
  1123.                             create_raise(node, symbol_constraint_error);
  1124.                             return;
  1125.                         }
  1126.                     }
  1127.                 }
  1128.             }
  1129.         }
  1130.     }
  1131. }
  1132.  
  1133. void complete_r_aggregate(Symbol aggregate_type, Node expn)
  1134.                                                     /*;complete_r_aggregate*/
  1135. {
  1136.     /* Perform resolution of components in a record aggregate. If the
  1137.      * record type has discriminants, we must first resolve the discriminant
  1138.      * components, in order to determine the variant parts to which the rest
  1139.      * of the aggregate must conform.
  1140.      */
  1141.  
  1142.     Tuple    arg_list, ttup, btup;
  1143.     Tuple    discr_list;
  1144.     int        first_named, exists, ctupi, num_discr;
  1145.     Tuple    positional_args;
  1146.     Tuple    named_args;
  1147.     int        discri;
  1148.     Node    comp_assoc, choice_list, choice_node, e, c_expr, others_expr;
  1149.     Tuple    discr_map, all_component_names;
  1150.     int i1, found_discr_val;
  1151.     char    *sel;
  1152.     Node    simple_name, others_comp_list, lnode;
  1153.     Symbol    discr, bs, ctupd, btype;
  1154.     Node    invariant_node, variant_node, ctupn;
  1155.     Declaredmap    sel_names;
  1156.     Tuple    leftovers;
  1157.     Node    discr_id, variant_list, alt;
  1158.     int        discr_value, lo, hi;
  1159.     Tuple    case_list;
  1160.     Node    case_node, component_list, list_node;
  1161.     Tuple    comp_assoc_list;
  1162.     int        comp_pos, i, j, k;
  1163.     Tuple    choices, components_seen;
  1164.     /*    sel                : IDENTIFIER;*/
  1165.     Symbol    selector;
  1166.     Fortup    ft1, ft2;
  1167.     int    found_discr_value;
  1168.  
  1169.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : complete_r_aggregate:");
  1170.  
  1171.     /* In SETL, components_seen is a set of symbols. Here we keep it as
  1172.      * tuple. Since it is a local variable, we allocate it here and free
  1173.      * it before every return from this procedure.
  1174.      */
  1175.     components_seen = tup_new(0);
  1176.     arg_list = N_LIST(expn);
  1177.     discr_list = (Tuple) discriminant_list(aggregate_type);
  1178.     num_discr = tup_size(discr_list);
  1179.     /* Components can be given by named choices. Divide argument list
  1180.      * into positional and named components .
  1181.      */
  1182.     exists = FALSE;
  1183.     FORTUPI(comp_assoc = (Node), arg_list, i, ft1);
  1184.         if (N_KIND(comp_assoc) == as_choice_list) {
  1185.             exists = TRUE;
  1186.             break;
  1187.         }
  1188.     ENDFORTUP(ft1);
  1189.     if (exists)
  1190.         first_named = i;
  1191.     else
  1192.         first_named = tup_size(arg_list) + 1;
  1193.  
  1194.     /* TBSL: positional_args and named_args may not have to be built
  1195.      * as separate tuples; if they are, should free on return
  1196.      * Also check that don't get into nasty boundary cases here
  1197.      * (building tuple of length -1, etc.
  1198.      */
  1199.     positional_args = tup_new(first_named-1);
  1200.     for (j = 1; j <= first_named-1; j++)
  1201.         positional_args[j] = arg_list[j];
  1202.     /*named_args = arg_list(first_named..);*/
  1203.     named_args = tup_new(tup_size(arg_list)-first_named+1);
  1204.     k = 1;
  1205.     for (j = first_named; j <= tup_size(arg_list); j++)
  1206.         named_args[k++] = arg_list[j];
  1207.     others_expr = (Node) 0;
  1208.     FORTUP(comp_assoc = (Node), named_args, ft1);
  1209.         choice_list = N_AST1(comp_assoc);
  1210.         c_expr = N_AST2(comp_assoc);
  1211.         exists = FALSE;
  1212.         FORTUP(choice_node = (Node), N_LIST(choice_list), ft2);
  1213.             if (N_KIND(choice_node) == as_others_choice) {
  1214.                 exists = TRUE;
  1215.                 break;
  1216.             }
  1217.         ENDFORTUP(ft2);
  1218.         if (exists) {
  1219.             if (tup_size( N_LIST(choice_list)) != 1
  1220.               || (comp_assoc != (Node)named_args[tup_size(named_args)])) {
  1221. #ifdef ERRNUM
  1222.                 errmsgn(306, 294, choice_node);
  1223. #else
  1224.                 errmsg("OTHERS must appear alone and last in a choice list",
  1225.                   "4.3", choice_node);
  1226. #endif
  1227.                 tup_free(components_seen);
  1228.                 return;
  1229.             }
  1230.             else {
  1231.                 others_expr = c_expr;
  1232.                 break;
  1233.             }
  1234.         }
  1235.     ENDFORTUP(ft1);
  1236.  
  1237.     discr_map = tup_new(0);
  1238.     if (num_discr > 0) {
  1239.         /* add value for 'constrained' bit, and do not check for it later.*/
  1240.         e = new_ivalue_node(int_const(TRUE), symbol_boolean);
  1241.         copy_span((Node)arg_list[1], e);
  1242.         discr_map = discr_map_put(discr_map, symbol_constrained, e);
  1243.     }
  1244.     /* Map the discriminants into the (hopefully) static expressions
  1245.      * given for them. Omit constrained bit from consideration.
  1246.      */
  1247.     i1 = num_discr == 0 ? 0:
  1248.       (num_discr -1 < tup_size(positional_args) ? num_discr -1 : 
  1249.       tup_size(positional_args));
  1250.     /* collect the positional discriminants first. */
  1251.     for (i = 1; i <= i1; i++) {
  1252.         comp_assoc = (Node) positional_args[i];
  1253.         discr_map =
  1254.           discr_map_put(discr_map, (Symbol) discr_list[i+1], comp_assoc);
  1255.     }
  1256.     /* Now look for named discriminants among named components.*/
  1257.  
  1258.     for (i = i1 + 2; i <= num_discr; i++) {
  1259.         discr = (Symbol) (discr_list[i]);
  1260.  
  1261.         found_discr_val = FALSE;
  1262.         FORTUP(comp_assoc = (Node), named_args, ft1);
  1263.             choice_list = N_AST1(comp_assoc);
  1264.             c_expr = N_AST2(comp_assoc);
  1265.             FORTUP(choice_node = (Node), N_LIST(choice_list), ft2);
  1266.                 if (N_KIND(choice_node) == as_choice_unresolved) {
  1267.                     simple_name = N_AST1(choice_node);
  1268.                     if (streq(N_VAL(simple_name), original_name(discr))) {
  1269.                         found_discr_val = TRUE;
  1270.                         goto endforcomp;
  1271.                     }
  1272.                 }
  1273.             ENDFORTUP(ft2);
  1274.         ENDFORTUP(ft1);
  1275. endforcomp:
  1276.         if (found_discr_val)
  1277.             discr_map = discr_map_put(discr_map, discr, c_expr);
  1278.         else if (others_expr != (Node)0)
  1279.             discr_map = discr_map_put(discr_map, discr,
  1280.               copy_tree(others_expr));
  1281.         else {
  1282. #ifdef ERRNUM
  1283.             id_errmsgn(307, discr, 308, expn);
  1284. #else
  1285.             errmsg_id("No value supplied for discriminant %", discr,
  1286.               "4.3.1", expn);
  1287. #endif
  1288.             tup_free(components_seen);
  1289.             return;
  1290.         }
  1291.     }
  1292.     /* perform type resolution on the associations for discriminants */
  1293.     for (discri = 1; discri <= tup_size(discr_map); discri += 2) {
  1294.         discr = (Symbol) discr_map[discri];
  1295.         c_expr = (Node) discr_map[discri+1];
  1296.         if (N_TYPE(c_expr) == (Symbol)0)
  1297.             check_type(TYPE_OF(discr), c_expr);
  1298.     }
  1299.     invariant_node = (Node) invariant_part(aggregate_type);
  1300.     variant_node = (Node)(variant_part(aggregate_type));
  1301.     sel_names = (Declaredmap) declared_components(aggregate_type);
  1302.     /* Now assemble the list of selector names. Each component declara-
  1303.      * tion declares a list of selectors with the same type.
  1304.      */
  1305.     all_component_names = build_comp_names(invariant_node);
  1306.     /* Scan the variant part of the record declaration, and collect the
  1307.      * types corresponding to the given discriminants.
  1308.      */
  1309.     while (variant_node != OPT_NODE) {
  1310.         found_discr_value = FALSE;
  1311.         discr_id = N_AST1(variant_node);
  1312.         variant_list = N_AST2(variant_node);
  1313.         c_expr = discr_map_get(discr_map, N_UNQ(discr_id));
  1314.         /* Verify that a discriminant which governs a variant part*/
  1315.         /* is static.*/
  1316.         if (!is_static_expr(c_expr)) {
  1317. #ifdef ERRNUM
  1318.             nval_errmsgn(309, discr_id, 308, c_expr);
  1319. #else
  1320.             errmsg_nval("Value for discriminant % must be static", discr_id,
  1321.               "4.3.1", c_expr);
  1322. #endif
  1323.             /* TBSL: this was N_UNQ, but probably should be N_VAL (gs Sep 20)*/
  1324.             tup_free(components_seen);
  1325.             return;
  1326.         }
  1327.  
  1328.         discr_value = INTV((Const)N_VAL(c_expr));
  1329.         case_list = N_LIST(variant_list);
  1330.         case_node = (Node)case_list[tup_size(case_list)];
  1331.         if (N_KIND(case_node) == as_others_choice)
  1332.             others_comp_list = N_AST2(case_node);
  1333.         else
  1334.             others_comp_list = (Node)0;
  1335.         FORTUP(case_node = (Node), case_list, ft1);
  1336.             choice_list = N_AST1(case_node);
  1337.             component_list = N_AST2(case_node);
  1338.             exists = FALSE;
  1339.             if (N_KIND(case_node) == as_others_choice) continue;
  1340.  
  1341.             FORTUP(alt = (Node), N_LIST(choice_list), ft2);
  1342.                 /* find the variant selected by given value of discriminant.
  1343.                     * all choices are now discrete ranges.
  1344.                  */
  1345.                 lo = INTV((Const)N_VAL(N_AST1(alt)));
  1346.                 hi = INTV((Const)N_VAL(N_AST2(alt)));
  1347.                 if (lo <= discr_value && discr_value <= hi) {
  1348.                     exists = TRUE;
  1349.                     break;
  1350.                 }
  1351.             ENDFORTUP(ft2);
  1352.             if (exists) {
  1353.                 /* Variants may be nested.*/
  1354.                 invariant_node = N_AST1(component_list);
  1355.                 variant_node = N_AST2(component_list);
  1356.                 /*all_component_names +:= build_comp_names(invariant_node);*/
  1357.                 btup = build_comp_names(invariant_node);
  1358.                 FORTUP(bs = (Symbol), btup, ft1);
  1359.                     all_component_names = tup_with(all_component_names,
  1360.                       (char *) bs);
  1361.                 ENDFORTUP(ft1);
  1362.                 tup_free(btup);
  1363.                 found_discr_value = TRUE;
  1364.                 break /*quit forall case_node*/;
  1365.             }
  1366.         ENDFORTUP(ft1);
  1367.  
  1368.         if (!found_discr_value) {
  1369.             if (others_comp_list != (Node)0) {
  1370.                 invariant_node = N_AST1(others_comp_list);
  1371.                 variant_node = N_AST2(others_comp_list);
  1372.                 btup = build_comp_names(invariant_node);
  1373.                 FORTUP(bs = (Symbol), btup, ft1);
  1374.                     all_component_names = tup_with(all_component_names,
  1375.                       (char *)bs);
  1376.                 ENDFORTUP(ft1);
  1377.                 tup_free(btup);
  1378.                 /*all_component_names +:=build_comp_names(invariant_node);*/
  1379.             }
  1380.             else {
  1381.                 create_raise(expn, symbol_constraint_error);
  1382.                 tup_free(components_seen);
  1383.                 return;
  1384.             }
  1385.         }
  1386.     }
  1387.  
  1388.     comp_pos = 1;       /* Index into list of selector assignments.*/
  1389.  
  1390.     /*components_seen = tup_new(0);  now allocated at start of proc*/
  1391.  
  1392.     if (cdebug2 > 0) {
  1393.         TO_ERRFILE("record fields are: ");
  1394.     }
  1395.     /* The list of component asssociations is built with pairs name -> expr
  1396.      * for all components present, including discriminants.
  1397.      */
  1398.     /*comp_assoc_list := [new_comp_assoc(d, v) : [d, v] in discr_map];*/
  1399.     comp_assoc_list = tup_new(tup_size(discr_map)/2);
  1400.     for (ctupi = 1; ctupi <= tup_size(discr_map); ctupi += 2) {
  1401.         ctupd = (Symbol) discr_map[ctupi];
  1402.         ctupn = (Node) discr_map[ctupi+1];
  1403.         comp_assoc_list[(ctupi+1)/2] = (char *) new_comp_assoc(ctupd, ctupn);
  1404.     }
  1405.     /* Perform resolution of all components following the positional
  1406.      * discriminants. Skip over named associations which are discriminants
  1407.      * since these have already been resolved.
  1408.      */
  1409.     for(i = i1+1; i <= tup_size(arg_list); i++) {
  1410.         comp_assoc = (Node) arg_list[i];
  1411.         if (N_KIND(comp_assoc) == as_choice_list) {
  1412.             choice_list = N_AST1(comp_assoc);
  1413.             c_expr = N_AST2(comp_assoc);
  1414.             choices = tup_new(0);
  1415.  
  1416.             FORTUP(choice_node = (Node), N_LIST(choice_list), ft1);
  1417.                 if (N_KIND(choice_node) == as_choice_unresolved) {
  1418.                     simple_name = N_AST1(choice_node);
  1419.                     sel = N_VAL(simple_name);
  1420.                     current_node = simple_name;
  1421.                     check_void(sel);
  1422.                     selector = dcl_get(sel_names, sel);
  1423.                     if (selector == (Symbol)0) {
  1424. #ifdef ERRNUM
  1425.                         errmsgn(310, 308, simple_name);
  1426. #else
  1427.                         errmsg("Undefined component name","4.3.1", simple_name);
  1428. #endif
  1429.                         tup_free(components_seen);
  1430.                         return;
  1431.                     }
  1432.                     choices = tup_with(choices, (char *) selector);
  1433.                     if (tup_mem((char *)selector, components_seen)) {
  1434. #ifdef ERRNUM
  1435.                         errmsgn(311, 308, simple_name);
  1436. #else
  1437.                         errmsg("Duplicate value for component in aggregate",
  1438.                           "4.3.1", simple_name);
  1439. #endif
  1440.                         tup_free(components_seen);
  1441.                         return;
  1442.                     }
  1443.                     else {
  1444.                         if (!tup_mem((char *)selector, components_seen))
  1445.                             components_seen =
  1446.                               tup_with(components_seen, (char *)selector);
  1447.                         if (NATURE(selector) != na_discriminant) {
  1448.                             if (tup_size(N_LIST(choice_list))> 1)
  1449.                                 /* copy expression node for each choice.*/
  1450.                                 e = copy_tree(c_expr);
  1451.                             else
  1452.                                 e = c_expr;
  1453.                             resolve_r_component(e, selector, discr_map);
  1454.                             comp_assoc_list = tup_with(comp_assoc_list,
  1455.                               (char *)new_comp_assoc(selector, e));
  1456.                         }
  1457.                         comp_pos += 1;
  1458.                     }
  1459.                 }
  1460.  
  1461.                 else if (N_KIND(choice_node) == as_simple_choice) {
  1462. #ifdef ERRNUM
  1463.                     errmsgn(312, 308, choice_node);
  1464. #else
  1465.                     errmsg("choice in record aggregate must be selector name",
  1466.                       "4.3.1", choice_node);
  1467. #endif
  1468.                     tup_free(components_seen);
  1469.                     return;
  1470.                 }
  1471.                 else if (N_KIND(choice_node) == as_range_choice) {
  1472. #ifdef ERRNUM
  1473.                     errmsgn(313, 308, choice_node);
  1474. #else
  1475.                     errmsg("Range choice not allowed in record aggregate",
  1476.                       "4.3.1", choice_node);
  1477. #endif
  1478.                     tup_free(components_seen);
  1479.                     return;
  1480.                 }
  1481.                 else if (N_KIND(choice_node) == as_others_choice) {
  1482.                     leftovers = tup_new(0);
  1483.                     FORTUP(selector = (Symbol), all_component_names, ft2);
  1484.                         if (!tup_mem((char *)selector, components_seen)) {
  1485.                             if (!tup_mem((char *) selector, leftovers))
  1486.                                 leftovers=tup_with(leftovers, (char *)selector);
  1487.                         }
  1488.                     ENDFORTUP(ft2);
  1489.  
  1490.                     if (tup_size( leftovers) == 0) {
  1491. #ifdef ERRNUM
  1492.                         l_errmsgn(314, 315, 308, choice_node);
  1493. #else
  1494.                         errmsg_l("OTHERS choice must represent at least ",
  1495.                           "one component", "4.3.1", choice_node);
  1496. #endif
  1497.                         tup_free(components_seen);
  1498.                         return;
  1499.                     }
  1500.                     else {
  1501.                         FORTUP(selector = (Symbol), leftovers, ft2);
  1502.                             if(! tup_mem((char *)selector, components_seen))
  1503.                                 components_seen = tup_with(components_seen, 
  1504.                                   (char *) selector);
  1505.                             if (NATURE(selector) != na_discriminant) {
  1506.                                 if (tup_size(leftovers)> 1) {
  1507.                                     /* copy expression node.*/
  1508.                                     e = copy_tree(c_expr);
  1509.                                 }
  1510.                                 else {
  1511.                                     e = c_expr;
  1512.                                 }
  1513.                                 resolve_r_component(e, selector, discr_map);
  1514.                                 if (N_TYPE(c_expr) == symbol_any) {
  1515. #ifdef ERRNUM
  1516.                                     id_errmsgn(316, selector, 308, choice_node);
  1517. #else
  1518.                                     errmsg_id(
  1519.                                       "OTHERS expression incompatible with %",
  1520.                                       selector, "4.3.1", choice_node);
  1521. #endif
  1522.                                     tup_free(components_seen);
  1523.                                     return;
  1524.                                 }
  1525.                                 comp_assoc_list = tup_with(comp_assoc_list,
  1526.                                   (char *)new_comp_assoc(selector, e));
  1527.                             }
  1528.                             choices = tup_with(choices, (char *) selector);
  1529.                         ENDFORTUP(ft2);
  1530.                     }
  1531.                 }
  1532.             ENDFORTUP(ft1);
  1533.  
  1534.             ttup= tup_new(0);
  1535.             FORTUP(selector = (Symbol), choices, ft2);
  1536.                 btype = base_type(TYPE_OF(selector));
  1537.                 if (!tup_mem((char *) btype, ttup))
  1538.                     ttup = tup_with(ttup, (char *) btype);
  1539.             ENDFORTUP(ft2);
  1540.             if (tup_size(ttup) > 1) {
  1541. #ifdef ERRNUM
  1542.                 errmsgn(317, 308, choice_list);
  1543. #else
  1544.                 errmsg("components on a choice list must have same type",
  1545.                   "4.3.1", choice_list);
  1546. #endif
  1547.             }
  1548.             tup_free(ttup);
  1549.         }
  1550.         else {    /* Positional record aggregate. */
  1551.             if (comp_pos > tup_size(all_component_names)) {
  1552. #ifdef ERRNUM
  1553.                 errmsgn(318, 10, expn);
  1554. #else
  1555.                 errmsg("Too many components for record aggregate","none", expn);
  1556. #endif
  1557.                 tup_free(components_seen);
  1558.                 return;
  1559.             }
  1560.             selector = (Symbol) all_component_names[comp_pos];
  1561.             resolve_r_component(comp_assoc, selector, discr_map);
  1562.             comp_pos += 1;
  1563.             if (!tup_mem((char *) selector, components_seen))
  1564.                 components_seen = tup_with(components_seen, (char *) selector);
  1565.             comp_assoc_list = tup_with(comp_assoc_list,
  1566.               (char *) new_comp_assoc(selector, comp_assoc));
  1567.         }
  1568.     }
  1569.  
  1570.     exists = FALSE;
  1571.     FORTUP(selector = (Symbol), all_component_names, ft1);
  1572.         if (!tup_mem((char *) selector, components_seen)) {
  1573.             exists = TRUE;
  1574.             break;
  1575.         }
  1576.     ENDFORTUP(ft1);
  1577.     if (exists)  {
  1578. #ifdef ERRNUM
  1579.         id_errmsgn(319, selector, 308, current_node);
  1580. #else
  1581.         errmsg_id("No value supplied for component %", selector, "4.3.1",
  1582.           current_node);
  1583. #endif
  1584.         tup_free(components_seen);
  1585.         return;
  1586.     }
  1587.     for (i = 1; i <= tup_size(comp_assoc_list); i++) {
  1588.         if (N_KIND(N_AST2((Node)comp_assoc_list[i])) == as_raise) {
  1589.             create_raise(expn, symbol_constraint_error);
  1590.             return;
  1591.         }
  1592.     }
  1593.     N_UNQ(expn) = sym_new(na_void);
  1594.     N_KIND(expn) = as_record_aggregate;
  1595.     N_LIST(expn) = (Tuple)0; /* clear out n_list */
  1596.     list_node = node_new(as_list);
  1597.     N_LIST(list_node) = comp_assoc_list;
  1598.     lnode = node_new(as_aggregate_list);
  1599.     N_AST1(lnode) = list_node;
  1600.     N_AST2(lnode) = OPT_NODE;
  1601.     N_AST1(expn) = lnode;
  1602.     N_AST2(expn) = OPT_NODE;
  1603. }
  1604.  
  1605. static Node new_comp_assoc(Symbol selector, Node expn)         /*;new_comp_assoc*/
  1606. {
  1607.     /* Used to normalize the representation of record aggregates: associate
  1608.      * a selector name with the expression given for it in the aggregate.
  1609.      */
  1610.  
  1611.     Node    c_node;
  1612.  
  1613.     c_node = node_new(as_record_choice);
  1614.     N_AST1(c_node) = new_name_node(selector);
  1615.     N_AST2(c_node) = expn;
  1616.     copy_span(expn, N_AST1(c_node));
  1617.     return c_node;
  1618. }
  1619.  
  1620. Tuple build_comp_names(Node invariant_node)    /*;build_comp_names*/
  1621. {
  1622.     /* Collect names of record components in the invariant part of the
  1623.      * record. Skip nodes generated for internal anonymous types.
  1624.      */
  1625.  
  1626.     Tuple    all_component_names;
  1627.     Node    node, id_list_node, id_node;
  1628.     Fortup    ft1, ft2;
  1629.  
  1630.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  build_comp_names");
  1631.  
  1632.     all_component_names = tup_new(0);
  1633.     FORTUP(node = (Node), N_LIST(invariant_node), ft1);
  1634.         if (N_KIND(node) == as_subtype_decl || N_KIND(node) == as_delayed_type)
  1635.             continue;
  1636.         id_list_node = N_AST1(node);
  1637.         FORTUP(id_node = (Node), N_LIST(id_list_node), ft2);
  1638.         /* test against 0 needed since in SETL om added at end of tuple
  1639.          * has no effect!    ds 14 aug
  1640.          * Skip over 'constrained' bit added by code generator (case of a
  1641.          * separately compiled record type definition.
  1642.          */
  1643.         if (N_UNQ(id_node) != (Symbol)0)
  1644.             all_component_names = tup_with(all_component_names,
  1645.               (char *) N_UNQ(id_node));
  1646.         ENDFORTUP(ft2);
  1647.     ENDFORTUP(ft1);
  1648.     return all_component_names;
  1649. }
  1650.  
  1651. static void resolve_r_component(Node e, Symbol selector, Tuple discr_map)
  1652.                                                     /*;resolve_r_component.*/
  1653. {  
  1654.     Symbol comp_type;
  1655.  
  1656.     resolve1(e);
  1657.     if (!noop_error) {
  1658.         comp_type = TYPE_OF(selector);
  1659.         /* if its bounds depend on discriminants, we emit subtypes with
  1660.          * the actual values of the discriminants given in the aggr. 
  1661.          */
  1662.         comp_type = check_discriminant_dependence(comp_type, discr_map);
  1663.         res2_check(e, comp_type);
  1664.     }
  1665. }
  1666.  
  1667. static Symbol check_discriminant_dependence(Symbol comp_type, Tuple discr_map)
  1668.                                             /*;check_discriminant_dependence*/
  1669. {
  1670.     /* if the subtype indication of a record component depends on a
  1671.      * discriminant, then the expression in a record aggregate that corresponds
  1672.      * to this component is given a subtype that is constrained by the values
  1673.      * of the discriminants that appear in the aggregate itself.
  1674.      */
  1675.  
  1676.     Tuple   constraint, new_constraint, tup, new_indices;
  1677.     Node    ubd, lbd, e;
  1678.     Symbol  d, type_name, index, new_index, new_type, new_acc;
  1679.     Tuple   comp_discr_map, new_discr_map;
  1680.     int     i, newi, new_t;
  1681.     Fortup  ft1;
  1682.  
  1683.     if (tup_size(discr_map) == 0) return comp_type;
  1684.  
  1685.     type_name = (is_access(comp_type)) ? (Symbol)designated_type(comp_type):
  1686.       comp_type;
  1687.  
  1688.     if (is_array(type_name)) {
  1689.         tup = index_types(type_name);
  1690.         new_indices = tup_new(0);
  1691.         FORTUP(index = (Symbol), tup, ft1)
  1692.             constraint = SIGNATURE(index);
  1693.             lbd = (Node)constraint[2];
  1694.             ubd = (Node)constraint[3];
  1695.             newi = FALSE;
  1696.             if (N_KIND(lbd) == as_discr_ref) {
  1697.                 lbd = discr_map_get(discr_map, N_UNQ(lbd));
  1698.                 newi = TRUE;
  1699.             }
  1700.             if (N_KIND(ubd) == as_discr_ref) {
  1701.                 ubd = discr_map_get(discr_map, N_UNQ(ubd));
  1702.                 newi = TRUE;
  1703.             }
  1704.             if (newi) {
  1705.                 new_index = sym_new(na_subtype);
  1706.                 dcl_put(DECLARED(scope_name), str_newat(), new_index);
  1707.                 new_constraint = constraint_new(CONSTRAINT_RANGE);
  1708.                 new_constraint[2]    = (char *)lbd;
  1709.                 new_constraint[3]    = (char *)ubd;
  1710.                 TYPE_OF(new_index)   = TYPE_OF(index);
  1711.                 SIGNATURE(new_index) = new_constraint;
  1712.                 SCOPE_OF(new_index)  = scope_name;
  1713.                 ALIAS      (new_index) = ALIAS(index);
  1714.                 new_indices = tup_with(new_indices, (char *)new_index);
  1715.                 new_t = TRUE;
  1716.             }
  1717.             else new_indices = tup_with(new_indices, (char *)index);
  1718.         ENDFORTUP(ft1);
  1719.         if (new_t) {
  1720.             /* create new subtype of array type, using new index types, and
  1721.              * label aggregate with this new array subtype.
  1722.              */
  1723.             new_type = sym_new(na_subtype);
  1724.             dcl_put(DECLARED(scope_name), str_newat(), new_type);
  1725.             TYPE_OF(new_type)      = base_type(type_name);
  1726.             SIGNATURE(new_type)    = tup_new(2);
  1727.             SIGNATURE(new_type)[1] = (char *)new_indices;
  1728.             SIGNATURE(new_type)[2] = (char *)component_type(type_name);
  1729.             SCOPE_OF(new_type)     = scope_name;
  1730.             ALIAS(new_type)        = ALIAS(type_name);
  1731.         }
  1732.         else {
  1733.             tup_free(new_indices);
  1734.             return comp_type;
  1735.         }
  1736.     }
  1737.     else if (NATURE(type_name) == na_subtype && is_record(type_name)) {
  1738.         /* see if any discriminant constraint is itself given by a discrimi-
  1739.          * nant (which must be a discriminant of the enclosing record.
  1740.          */
  1741.         comp_discr_map = (Tuple)numeric_constraint_discr(SIGNATURE(type_name));
  1742.         new_discr_map = tup_new(0);
  1743.         newi = FALSE;
  1744.         for (i = 1; i <= tup_size(comp_discr_map); i += 2) {
  1745.             d = (Symbol)comp_discr_map[i];
  1746.             e = (Node)  comp_discr_map[i+1];
  1747.             if (N_KIND(e) == as_discr_ref) {
  1748.                 /* replace discriminant reference with value given in enclosing
  1749.                  * aggregate.
  1750.                  */
  1751.                 newi = TRUE;
  1752.                 new_discr_map = discr_map_put(new_discr_map, d,
  1753.                   copy_tree(discr_map_get(discr_map, N_UNQ(e))));
  1754.             }
  1755.             else
  1756.                 new_discr_map = discr_map_put(new_discr_map, d, e);
  1757.         }
  1758.         if (newi) {
  1759.             new_type = sym_new(na_subtype);
  1760.             dcl_put(DECLARED(scope_name), str_newat(), new_type);
  1761.             tup = constraint_new(CONSTRAINT_DISCR);
  1762.             numeric_constraint_discr(tup) = (char *)new_discr_map;
  1763.             TYPE_OF(new_type)      = TYPE_OF(type_name);
  1764.             SIGNATURE(new_type)    = tup;
  1765.             OVERLOADS(new_type)    = OVERLOADS(type_name);
  1766.             SCOPE_OF(new_type)     = scope_name;
  1767.             ALIAS(new_type)        = ALIAS(type_name);
  1768.         }
  1769.         else {
  1770.             tup_free(new_discr_map);
  1771.             return comp_type;
  1772.         }
  1773.     }
  1774.     else {
  1775.         /* cannot be a discriminant constraint.*/
  1776.         return comp_type;
  1777.     }
  1778.     if (is_access(comp_type)) {
  1779.         /* create access type to new constrained array type.*/
  1780.         new_acc = sym_new(na_subtype);
  1781.         dcl_put(DECLARED(scope_name), str_newat(), new_acc);
  1782.         TYPE_OF(new_acc)      = TYPE_OF(comp_type);
  1783.         SIGNATURE(new_acc)    = constraint_new(CONSTRAINT_ACCESS);
  1784.         SIGNATURE(new_acc)[2] = (char *)new_type;    /*designated type*/
  1785.         SCOPE_OF(new_acc)     = scope_name;
  1786.         ALIAS(new_acc)        = ALIAS(comp_type);
  1787.         return new_acc;
  1788.     }
  1789.     else
  1790.         return new_type;
  1791. }
  1792.  
  1793. void valid_task_name(Node task_name)                     /*;valid_task_name*/
  1794. {
  1795.     /* First pass over an expression that must yield a task type: called to
  1796.      * resolve entry names.
  1797.      */
  1798.  
  1799.     Set    task_types;
  1800.     Forset    fs1;
  1801.     Symbol    t;
  1802.  
  1803.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : valid_task_name");
  1804.  
  1805.     resolve1(task_name);
  1806.     task_types = set_new(0);
  1807.     FORSET(t = (Symbol), N_PTYPES(task_name), fs1);
  1808.         if (is_task_type(t)
  1809.           || (is_access(t) && is_task_type(designated_type(t))))
  1810.             task_types = set_with(task_types, (char *) t);
  1811.     ENDFORSET(fs1);
  1812.  
  1813.     if (set_size(task_types) == 0) {
  1814. #ifdef ERRNUM
  1815.         errmsgn(320, 321, task_name);
  1816. #else
  1817.         errmsg("expect task name ", "9.5", task_name);
  1818. #endif
  1819.     }
  1820.  
  1821.     N_PTYPES(task_name) = task_types;
  1822. }
  1823.  
  1824. void complete_task_name(Node task1, Symbol context_typ)  /*;complete_task_name*/
  1825. {
  1826.     /* Complete resolution of task name used in an entry name.The context_typ
  1827.      * is obtained from the    scope of  the resolved    entry name. Derived task
  1828.      * types have the same entries as their root type, and the unique type of
  1829.      * the task name is thus the one whose root type is the context type.
  1830.      */
  1831.  
  1832.     Node    a_task;
  1833.     Set    types;
  1834.     Symbol    t, tmp;
  1835.     int    exists;
  1836.     Forset    fs1;
  1837.     Symbol    t_n;
  1838.  
  1839.     if (cdebug2 > 3)  TO_ERRFILE("AT PROC : complete_task_name");
  1840.  
  1841.     types = N_PTYPES(task1);
  1842.     exists = FALSE;
  1843.     FORSET(t = (Symbol), types, fs1);
  1844.         if (root_type(t) == context_typ) {
  1845.             exists = TRUE;
  1846.             break;
  1847.         }
  1848.     ENDFORSET(fs1);
  1849.     if (exists) {
  1850.         resolve2(task1, t);
  1851.         if (N_KIND(task1) != as_simple_name) eval_static(task1);
  1852.     }
  1853.     else {
  1854.         exists = FALSE;
  1855.         FORSET(t = (Symbol), types, fs1);
  1856.             tmp =  (Symbol) designated_type(t);
  1857.             if (is_access(t) &&
  1858.                 root_type(tmp) == context_typ) {
  1859.                 exists = TRUE;
  1860.                 break;
  1861.             }
  1862.         ENDFORSET(fs1);
  1863.         if (exists) {
  1864.             resolve2(task1, t);
  1865.             if (N_KIND(task1) != as_simple_name) eval_static(task1);
  1866.             a_task = copy_node(task1);
  1867.             N_KIND(task1) = as_all; /* explicit dereference*/
  1868.             N_AST1(task1) = a_task; /* of access to task*/
  1869.             N_AST2(task1) = N_AST3(task1) = N_AST4(task1) = (Node) 0;
  1870.             N_TYPE(task1) = (Symbol) designated_type(t);
  1871.         }
  1872.         else { /* previous error.*/
  1873.             return;
  1874.         }
  1875.     }
  1876.     /* Within the task body a task type designates the object currently exe-
  1877.      * cuting that task. We replace the task type with  what will be     its
  1878.      * run-time identity.
  1879.      */
  1880.     t_n = N_UNQ(task1);
  1881.     if (N_KIND(task1) == as_simple_name && is_task_type(t_n)) {
  1882.         if (in_open_scopes(t_n))
  1883.             N_UNQ(task1) = dcl_get(DECLARED(t_n), "current_task");
  1884.         else {
  1885.             /* Use of the task type otherwise is invalid.*/
  1886. #ifdef ERRNUM
  1887.             errmsgn(322, 323, task1);
  1888. #else
  1889.             errmsg("invalid use of task type outside of its own body", "9.1",
  1890.               task1);
  1891. #endif
  1892.         }
  1893.     }
  1894. }
  1895.  
  1896. void res2_check(Node expn2, Symbol context_type)            /*;res2_check*/
  1897. {
  1898.     /* Called to impose constraints when needed, on aggregate components
  1899.      * and allocated objects. These are non-sliding contexts for aggregates.
  1900.      */
  1901.  
  1902.     int may_others;
  1903.  
  1904.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  res2_check");
  1905.  
  1906.     may_others = full_others;
  1907.     full_others = TRUE;
  1908.     resolve2(expn2, context_type);
  1909.  
  1910.     apply_constraint(expn2, context_type);
  1911.     full_others = may_others;
  1912.     if (!noop_error)
  1913.         eval_static(expn2);
  1914. }
  1915.  
  1916. Symbol attribute_type(int attribute, Symbol typ, Node arg1, Node arg2)
  1917.                                                         /*;attribute_type*/
  1918. {
  1919.     /* -attribute- is a predefined attribute. arg1 is the first arg,
  1920.      * whose type is typ, and arg2 is the second argument (or a dummy 1).
  1921.      * The result type of an attribute is either a numeric type, or
  1922.      * the type of its first argument (    attributes of enumerations).
  1923.      * FIRST and LAST are more complicated : they return the first
  1924.      * value of the index type of the i'th dimension of their first
  1925.      * argument.
  1926.      * For enumeration types, FIRST and LAST simply return the type
  1927.      * of the first argument.
  1928.      */
  1929.  
  1930.     Symbol    n;
  1931.     Set        types2;
  1932.     int        dim;
  1933.     Symbol    a_type, root, t, t2;
  1934.     int        type_ok, exists;
  1935.     Forset    fs1;
  1936.     Unitdecl    ud;
  1937.  
  1938.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : attribute_type");
  1939.  
  1940.     n = N_UNQ(arg2);
  1941.     if ((N_KIND(arg2) == as_simple_name) && (n != (Symbol)0))
  1942.         N_PTYPES(arg2) = set_new1((char *) TYPE_OF(n));
  1943.     else
  1944.         resolve1(arg2);        /* Begin resolution of second arg*/
  1945.  
  1946.     types2 = N_PTYPES(arg2);
  1947.     if (types2 == (Set)0) types2 = set_new(0);
  1948.     if (set_size(types2) == 0)    /* Some type error .*/
  1949.         return symbol_any;
  1950.  
  1951.     if ( attribute == ATTR_O_FIRST || attribute == ATTR_T_FIRST
  1952.       || attribute == ATTR_O_LAST || attribute == ATTR_T_LAST
  1953.       || attribute == ATTR_O_RANGE || attribute == ATTR_T_RANGE
  1954.       || attribute == ATTR_O_LENGTH || attribute == ATTR_T_LENGTH) {
  1955.         /* The second argument must be a universal integer, and
  1956.          * and must be static. Complete its resolution now.
  1957.           */
  1958.         if (set_mem((char *) symbol_universal_integer, types2)) {
  1959.             resolve2(arg2, symbol_universal_integer);
  1960.             specialize(arg2, symbol_integer);
  1961.         }
  1962.         else
  1963.             pass1_error_str("index number of attribute % must be universal",
  1964.               attribute_str(attribute), "Appendix A", arg2);
  1965.  
  1966.         if (! is_static_expr(arg2)
  1967.           || N_KIND(arg2) != as_ivalue 
  1968.           || ((Const)N_VAL(arg2))->const_kind != CONST_INT) {
  1969.             pass1_error_str("Second argument of % must be static integer", 
  1970.               attribute_str(attribute), "3.6.2", arg2); /* ?? */
  1971.  
  1972.             dim = 1;    /* assume 1*/
  1973.         }
  1974.         else dim = INTV((Const)N_VAL(arg2));
  1975.  
  1976.         a_type = typ;
  1977.         if (is_array(typ)) {
  1978.             if (is_type_node(arg1) && can_constrain(N_UNQ(arg1))) {
  1979.                 pass1_error_str("Unconstrained array type for attribute %",
  1980.                   attribute_str(attribute), "3.6.2", arg1);
  1981.                 return symbol_any;
  1982.             }
  1983.             if ( (dim > no_dimensions(typ)) || (dim < 1)) {
  1984.                 pass1_error_l("Invalid dimension number for array type",
  1985.                   " in attribute", "3.6.2", arg1);
  1986.                 return symbol_any;
  1987.             }
  1988.             if (attribute == ATTR_O_LENGTH || attribute == ATTR_T_LENGTH)
  1989.                 a_type = symbol_universal_integer;
  1990.             else {
  1991.                 /* Get type of index for specified dimension.*/
  1992.                 a_type = (Symbol) index_types(a_type)[dim];
  1993.             }
  1994.         }
  1995.     }
  1996.     else if (attribute == ATTR_ADDRESS) {
  1997.         ud = unit_decl_get("spSYSTEM");
  1998.         if (ud == (Unitdecl)0 || !in_vis_mods(ud->ud_unam)) {
  1999.             /* The use of this attribute seems incorrect if its type
  2000.              * cannot be named.
  2001.              */
  2002. #ifdef ERRNUM
  2003.             errmsgn(324, 325, arg1);
  2004. #else
  2005.             errmsg("use of SYSTEM.ADDRESS requires presence of package SYSTEM",
  2006.               "13.7.2, Annex A", arg1);
  2007. #endif
  2008.             a_type = symbol_integer; /* Closest thing we've got.*/
  2009.         }
  2010.         else {
  2011.             /*a_type = ??visible('SYSTEM')('ADDRESS');*/
  2012.             a_type = dcl_get_vis(DECLARED(ud->ud_unam), "ADDRESS");
  2013.         }
  2014.     }
  2015.     else if (attribute != ATTR_BASE
  2016.       &&     attribute != ATTR_T_FIRST && attribute != ATTR_O_FIRST
  2017.       &&     attribute != ATTR_O_LAST && attribute != ATTR_T_LAST
  2018.       &&     attribute != ATTR_PRED
  2019.       &&     attribute != ATTR_O_RANGE && attribute != ATTR_T_RANGE
  2020.       &&     attribute != ATTR_SUCC
  2021.       &&     attribute != ATTR_VAL
  2022.       &&     attribute != ATTR_VALUE) {
  2023.  
  2024.         /*a_type = TYPE_OF(attribute);*/
  2025.         if ( attribute == ATTR_AFT
  2026.           || attribute == ATTR_COUNT
  2027.           || attribute == ATTR_DIGITS 
  2028.           || attribute == ATTR_EMAX 
  2029.           || attribute == ATTR_FIRST_BIT 
  2030.           || attribute == ATTR_FORE 
  2031.           || attribute == ATTR_LAST_BIT 
  2032.           || attribute == ATTR_LAST_BIT 
  2033.           || attribute == ATTR_O_LENGTH || attribute == ATTR_T_LENGTH 
  2034.           || attribute == ATTR_MACHINE_EMAX 
  2035.           || attribute == ATTR_MACHINE_EMIN 
  2036.           || attribute == ATTR_MACHINE_MANTISSA 
  2037.           || attribute == ATTR_MACHINE_RADIX 
  2038.           || attribute == ATTR_MANTISSA 
  2039.           || attribute == ATTR_POS 
  2040.           || attribute == ATTR_POSITION 
  2041.           || attribute == ATTR_SAFE_EMAX 
  2042.           || attribute == ATTR_O_SIZE || attribute == ATTR_T_SIZE 
  2043.           || attribute == ATTR_STORAGE_SIZE 
  2044.           || attribute == ATTR_WIDTH) {
  2045.             a_type = symbol_universal_integer;
  2046.         }
  2047.         else if (attribute == ATTR_DELTA
  2048.           ||     attribute == ATTR_EPSILON    
  2049.           ||     attribute == ATTR_LARGE    
  2050.           ||     attribute == ATTR_SMALL    
  2051.           ||     attribute == ATTR_SAFE_LARGE    
  2052.           ||     attribute == ATTR_SAFE_SMALL) {
  2053.             a_type = symbol_universal_real;
  2054.         }
  2055.         else if (attribute==ATTR_O_CONSTRAINED || attribute==ATTR_T_CONSTRAINED
  2056.           ||     attribute == ATTR_MACHINE_OVERFLOWS    
  2057.           ||     attribute == ATTR_MACHINE_ROUNDS    
  2058.           ||     attribute == ATTR_CALLABLE    
  2059.           ||     attribute == ATTR_TERMINATED) {
  2060.             a_type = symbol_boolean;
  2061.         }
  2062.         else if (attribute == ATTR_IMAGE)
  2063.             a_type = symbol_string;
  2064.     }
  2065.     else if (attribute == ATTR_BASE
  2066.       ||     attribute == ATTR_POS
  2067.       ||     attribute == ATTR_PRED
  2068.       ||     attribute == ATTR_SUCC
  2069.       ||     attribute == ATTR_VAL
  2070.       ||     attribute == ATTR_VALUE) {
  2071.         a_type = base_type(typ);
  2072.     }
  2073.     else {
  2074.         a_type = typ;
  2075.     }
  2076.  
  2077.     root = root_type(typ);
  2078.  
  2079.     /* Now verify that the type of the argument is valid for the attribute.*/
  2080.  
  2081.     t = N_UNQ(arg1);
  2082.     if (t != (Symbol)0 && tup_mem((char *) t, open_scopes)
  2083.       && NATURE(t) == na_record) {
  2084. #ifdef ERRNUM
  2085.         id_errmsgn(206, t, 207, arg1);
  2086.         /* ?? */
  2087. #else
  2088.         errmsg_id("Invalid self-reference in definition of %", t, "3.1", arg1);
  2089.          /* ?? */
  2090. #endif
  2091.         return symbol_any;
  2092.     }
  2093.  
  2094.     if (attribute == ATTR_ADDRESS)
  2095.         type_ok =  !is_type_node(arg1);
  2096.     else if (attribute == ATTR_BASE)
  2097.         type_ok =      is_type(root);
  2098.     else if (attribute == ATTR_T_FIRST || attribute == ATTR_O_FIRST
  2099.       || attribute == ATTR_O_LAST || attribute == ATTR_T_LAST)
  2100.         type_ok =  is_scalar_type(root) || is_array(root);
  2101.     else if (attribute == ATTR_VALUE) {
  2102.         if (!is_discrete_type(root))
  2103.             type_ok = FALSE;
  2104.         else {
  2105.             exists = FALSE;
  2106.             FORSET(t2 = (Symbol), types2, fs1);
  2107.                 if (compatible_types(symbol_string, t2)) {
  2108.                     exists = TRUE;
  2109.                     break;
  2110.                 }
  2111.             ENDFORSET(fs1);
  2112.             type_ok = exists;
  2113.         }
  2114.     }
  2115.     else if (attribute == ATTR_IMAGE
  2116.       ||     attribute == ATTR_POS
  2117.       ||     attribute == ATTR_PRED
  2118.       ||     attribute == ATTR_SUCC) {
  2119.         if (! is_discrete_type(root))
  2120.             type_ok = FALSE;
  2121.         else {
  2122.             exists = FALSE;
  2123.             FORSET(t2 = (Symbol), types2, fs1);
  2124.                 if (compatible_types(typ, t2)) {
  2125.                     exists = TRUE;
  2126.                     break;
  2127.                 }
  2128.             ENDFORSET(fs1);
  2129.             type_ok =  exists;
  2130.         }
  2131.     }
  2132.     else if (attribute == ATTR_VAL) {
  2133.         if (!is_discrete_type(root))
  2134.             type_ok = FALSE;
  2135.         else {
  2136.             exists = FALSE;
  2137.             FORSET(t2 = (Symbol), types2, fs1);
  2138.                 if (is_integer_type(root_type(t2))) {
  2139.                     exists = TRUE;
  2140.                     break;
  2141.                 }
  2142.             ENDFORSET(fs1);
  2143.             type_ok =  exists;
  2144.         }
  2145.     }
  2146.     else if (attribute == ATTR_AFT
  2147.       ||     attribute == ATTR_DELTA
  2148.       ||     attribute == ATTR_FORE) {
  2149.         type_ok =   is_fixed_type(root);
  2150.     }
  2151.     else if (attribute == ATTR_DIGITS
  2152.       ||     attribute == ATTR_EMAX
  2153.       ||     attribute == ATTR_EPSILON
  2154.       ||     attribute == ATTR_MACHINE_RADIX
  2155.       ||     attribute == ATTR_MACHINE_MANTISSA
  2156.       ||     attribute == ATTR_MACHINE_EMAX
  2157.       ||     attribute == ATTR_MACHINE_EMIN
  2158.       ||     attribute == ATTR_SAFE_EMAX) {
  2159.         type_ok =        root == symbol_float;
  2160.     }
  2161.     else if (attribute == ATTR_LARGE
  2162.       ||    attribute == ATTR_MACHINE_ROUNDS
  2163.       ||    attribute == ATTR_MACHINE_OVERFLOWS
  2164.       ||    attribute == ATTR_MANTISSA
  2165.       ||    attribute == ATTR_SMALL
  2166.       ||    attribute == ATTR_SAFE_LARGE
  2167.       ||    attribute == ATTR_SAFE_SMALL) {
  2168.         if (is_fixed_type(root) || root == symbol_float)
  2169.             type_ok = TRUE;
  2170.         else
  2171.             type_ok = FALSE;
  2172.     }
  2173.     else if (attribute == ATTR_O_LENGTH || attribute == ATTR_T_LENGTH
  2174.       || attribute == ATTR_O_RANGE || attribute == ATTR_T_RANGE)
  2175.         type_ok = is_array(root);
  2176.     else if (attribute==ATTR_O_CONSTRAINED || attribute == ATTR_T_CONSTRAINED) {
  2177.         if (is_type_node(arg1))
  2178.             type_ok = is_private(typ);
  2179.         else if ( is_record(root) && has_discriminants(root))
  2180.             type_ok = TRUE;
  2181.         else
  2182.             type_ok = FALSE;
  2183.     }
  2184.     else if (attribute == ATTR_TERMINATED || attribute == ATTR_CALLABLE) {
  2185.         if (is_access(root)) root = (Symbol) designated_type(root);
  2186.         type_ok =  is_task_type(root);
  2187.     }
  2188.     else if (attribute == ATTR_STORAGE_SIZE)
  2189.         type_ok =  (is_task_type(root) || is_access(root));
  2190.     else if (attribute == ATTR_WIDTH)
  2191.         type_ok = is_discrete_type(root);
  2192.  
  2193.     else if (attribute == ATTR_COUNT
  2194.       ||    attribute == ATTR_FIRST_BIT
  2195.       ||    attribute == ATTR_LAST_BIT
  2196.       ||    attribute == ATTR_O_SIZE || attribute == ATTR_T_SIZE
  2197.       ||    attribute == ATTR_POSITION) {
  2198.         type_ok =  TRUE;
  2199.     }
  2200.  
  2201.     else {
  2202. #ifdef ERRNUM
  2203.         str_errmsgn(326, attribute_str(attribute), 233, arg1);
  2204. #else
  2205.         errmsg_str("Undefined attribute: %", attribute_str(attribute),
  2206.           "Annex A", arg1);
  2207. #endif
  2208.         a_type = symbol_any;
  2209.         type_ok = TRUE;
  2210.     }
  2211.  
  2212.     if (type_ok) return a_type;
  2213.     else {
  2214.         pass1_error_str("Invalid argument type for attribute %",
  2215.           attribute_str(attribute), "Annex A", arg1);
  2216.         return symbol_any;
  2217.     }
  2218. }
  2219.  
  2220. int compatible_types(Symbol t_out, Symbol t_in) /*;compatible_types*/
  2221. {
  2222.     /* This procedure verifies that an expression of type -t_in- can appear
  2223.      * in a context requiring type -t_out-. In the case of subtypes this
  2224.      * procedure indicates whether a run-time check will be necessary.
  2225.      * Equality, set and comparison operators carry a special type-marker which
  2226.      * is ignored on the first pass of type resolution, because the type of
  2227.      * the arguments of these operators have no effect on the result type.
  2228.      * On the second pass, these special type-markers are used to indicate
  2229.      * the need for a consistency check among the types of the two actual
  2230.      * parameters themselves.
  2231.      */
  2232.  
  2233.     Symbol    r;
  2234.     int    n;
  2235.     Symbol tmp;
  2236.  
  2237.     if (cdebug2 > 0) {
  2238.         TO_ERRFILE("check compatible types ");
  2239.         printf("  %s %s\n", ((t_out != (Symbol)0) ? ORIG_NAME(t_out): ""),
  2240.           ((t_in != (Symbol) 0)? ORIG_NAME(t_in) : ""));
  2241.     }
  2242.     if (t_in == (Symbol)0 || t_out == (Symbol)0    /* syntax error*/
  2243.       || (t_in == t_out)    /*compatible types*/
  2244.       || in_multiple_types(t_in) || in_multiple_types(t_out)) {
  2245.         return TRUE;
  2246.     }
  2247.     /* The generic types 'universal_integer', 'universal_real', 'string_type'
  2248.      * and '$FIXED' are used to indicate the type of the corresponding literals.
  2249.      * These types are compatible with specific types of the same family.
  2250.      * On the other hand, the generic 'universal_fixed' is incompatible
  2251.      * with all types, and its presence in any type checking will trigger an
  2252.      * error message, at some point.
  2253.      * To avoid checking for their presence on both sides, we perform the
  2254.      * following normalization :
  2255.      */
  2256.     if (!in_gen_types(t_in) && in_gen_types(t_out)) {
  2257.         tmp = t_in; 
  2258.         t_in = t_out; 
  2259.         t_out = tmp;
  2260.     }
  2261.  
  2262.     if (t_in == symbol_universal_integer)
  2263.         return ( root_type(t_out) == symbol_integer);
  2264.     else if(t_in == symbol_universal_real)
  2265.         return (root_type(t_out) == symbol_float ||
  2266.           (t_out != symbol_universal_fixed && is_fixed_type(root_type(t_out))));
  2267.     else if (t_in == symbol_universal_type)
  2268.         return in_univ_types(t_out);
  2269.     else if (t_in == symbol_dfixed)
  2270.         return (t_out == symbol_universal_real || is_fixed_type(t_out));
  2271.     else if (t_in == symbol_boolean_type)
  2272.         return (root_type(t_out) == symbol_boolean || (is_array(t_out)
  2273.           && root_type((Symbol) component_type(t_out)) == symbol_boolean));
  2274.     else if (t_in == symbol_discrete_type)
  2275.         return(        is_discrete_type(t_out));
  2276.     else if(t_in == symbol_integer_type)
  2277.         return (root_type(t_out) == symbol_integer
  2278.           || t_out == symbol_universal_integer);
  2279.     else if (t_in == symbol_real_type) {
  2280.         r = root_type(t_out);
  2281.         return (r == symbol_float 
  2282.           || (r != symbol_universal_fixed && is_fixed_type(r))
  2283.           || r == symbol_universal_real);
  2284.     }
  2285.     else if(t_in == symbol_string_type)
  2286.         return (is_array(t_out) && no_dimensions(t_out) ==  1
  2287.           && is_character_type(component_type(t_out)));
  2288.     else if(t_in == symbol_character_type)
  2289.         return(is_character_type(t_out));
  2290.     else if (t_in == symbol_array_type)
  2291.         return(is_array(t_out));
  2292.     else if (t_in == symbol_composite_type) {
  2293.         n = NATURE(root_type(t_out));
  2294.         return(n == na_array || n == na_record);
  2295.     }
  2296.     else if(t_in == symbol_universal_fixed)
  2297.         return     FALSE;
  2298.     else
  2299.         /* name equivalence of base types holds for everything else.*/
  2300.         return  (base_type(t_in) == base_type(t_out));
  2301. }
  2302.  
  2303. static int in_gen_types(Symbol t)                         /*;in_gen_types*/
  2304. {
  2305.     return (
  2306.         t == symbol_array_type    
  2307.      || t == symbol_boolean_type  
  2308.      || t == symbol_character_type 
  2309.      || t == symbol_composite_type
  2310.      || t == symbol_discrete_type 
  2311.      || t == symbol_dfixed
  2312.      || t == symbol_integer_type   
  2313.      || t == symbol_real_type
  2314.      || t == symbol_string_type     
  2315.      || t == symbol_universal_integer 
  2316.      || t == symbol_universal_real
  2317.      || t == symbol_universal_fixed 
  2318.      || t == symbol_universal_type);
  2319. }
  2320.  
  2321. static int in_multiple_types(Symbol t)  /*;in_multiple_types*/
  2322. {
  2323.     return (t == symbol_equal_type
  2324.       ||    t == symbol_order_type
  2325.       ||    t == symbol_any);
  2326. }
  2327.  
  2328. void type_error(Set op_names, Symbol typ, int num_types, Node node)
  2329.                                                                 /*;type_error*/
  2330. {
  2331.     /* Emit error message after a type error was detected during
  2332.      * type resolution.
  2333.      * if num_types > 1, the expression is ambiguous : the operator of
  2334.      * op_names is overloaded, and the argument list is not sufficient to
  2335.      * disambiguate.
  2336.      * If num_types = 0, the argument list is incompatible with the op.
  2337.      */
  2338.  
  2339.     Symbol    op_name;
  2340.     char    *op_n; /*TBSL: check type of op_n*/
  2341.     char    *names;
  2342.     int        nat;
  2343.  
  2344.     if (cdebug2 > 3) {
  2345.         TO_ERRFILE("AT PROC :  type_error");
  2346. #ifdef TBSL
  2347.         TO_ERRFILE('opname=' + str op_names);
  2348. #endif
  2349.     }
  2350.  
  2351.     /* avoid taking set_arb of empty set    ds 8 aug */
  2352.     if (set_size(op_names) == 0)
  2353.         op_name = (Symbol)symbol_undef;
  2354.         /* this should parallel SETL   gcs 19 feb 
  2355.          * Looks like noop_error should be set (but is not) 
  2356.          */
  2357.     else
  2358.         op_name = (Symbol) set_arb(op_names);
  2359.  
  2360.     op_n = ORIG_NAME(op_name);
  2361.     if (N_KIND(node) == as_simple_name)
  2362.         N_UNQ(node) = op_name;    /* to avoid cascaded errors */
  2363.     if (num_types > 1) {
  2364.         nat = NATURE(op_name);
  2365.  
  2366.         if (nat == na_procedure || nat == na_function 
  2367.           || nat == na_procedure_spec || nat == na_function_spec) {
  2368. #ifdef TBSL
  2369.             names :
  2370.                 = +/[original_name(scope_of(x)) + '.' +
  2371.                     original_name(x) + ' ' : x in  op_names];
  2372. #endif
  2373.             names = build_full_names(op_names);
  2374. #ifdef ERRNUM
  2375.             str_errmsgn(327, names, 328, node);
  2376. #else
  2377.             errmsg_str("Ambiguous call to one of %", names, "6.6, 8.3", node);
  2378. #endif
  2379.         }
  2380.         else if (nat == na_op) {
  2381. #ifdef ERRNUM
  2382.             str_errmsgn(329, op_n, 330, node);
  2383. #else
  2384.             errmsg_str("Ambiguous operands for %", op_n, "6.7, 8.3", node);
  2385. #endif
  2386.         }
  2387.         else if (nat == na_literal) {
  2388. #ifdef ERRNUM
  2389.             str_errmsgn(331, op_n, 332, node);
  2390. #else
  2391.             errmsg_str("Ambiguous literal: %", op_n, "3.5.1, 4.7, 8.3", node);
  2392. #endif
  2393.         }
  2394.  
  2395.         else {
  2396. #ifdef ERRNUM
  2397.             errmsgn(333, 334, node);
  2398. #else
  2399.             errmsg("ambiguous expression", "8.2, 8.3", node);
  2400. #endif
  2401.         }
  2402.  
  2403.         /* If the type is ambiguous the expression is of couse invalid.*/
  2404.  
  2405.         noop_error = TRUE;
  2406.     }
  2407.     else {        /* Num_types is zero.*/
  2408.         if (noop_error) {
  2409.             /* Current expression contained previous error. Do not emit
  2410.              * an aditional one.
  2411.              */
  2412.             return;
  2413.         }
  2414.  
  2415.         noop_error = TRUE; /* For sure.*/
  2416.  
  2417.         if (typ == (Symbol) 0) {    /* Operator or subprogram .*/
  2418.             if (strcmp(op_n, "GET") == 0 || strcmp(op_n, "PUT") == 0) {
  2419. #ifdef ERRNUM
  2420.                 errmsgn(335, 336, node);
  2421. #else
  2422.                 errmsg("TEXT_IO not instantiated nor defined for type",
  2423.                   "8.4, 14.4", node);
  2424. #endif
  2425.             }
  2426.             else {
  2427.                 if (NATURE(op_name) == na_entry
  2428.                   || NATURE(op_name) == na_entry_family) {
  2429.                     op_n = "entry call";
  2430.                 }
  2431.                 if (NATURE(op_name) == na_op)
  2432. #ifdef ERRNUM
  2433.                     str_errmsgn(337, op_n, 10, node);
  2434. #else
  2435.                     errmsg_str("invalid types for %", op_n, "none", node);
  2436. #endif
  2437.                 else {
  2438. #ifdef ERRNUM
  2439.                     str_errmsgn(338, op_n, 10, node);
  2440. #else
  2441.                     errmsg_str("invalid argument list for %",op_n,"none", node);
  2442. #endif
  2443.                 }
  2444.             }
  2445.         }
  2446.         else if (NATURE(op_name) == na_literal) {
  2447. #ifdef ERRNUM
  2448.             id_type_errmsgn(339, op_name, typ, 340, node);
  2449. #else
  2450.             errmsg_id_type("no instance of % has type %", op_name, typ,
  2451.               "3.5.1", node);
  2452. #endif
  2453.         }
  2454.         else {
  2455. #ifdef ERRNUM
  2456.             type_errmsgn(341, typ, 10, node);
  2457. #else
  2458.             errmsg_type("Expect expression to yield type %", typ, "none", node);
  2459. #endif
  2460.         }
  2461.     }
  2462. }
  2463.  
  2464. void premature_access(Symbol type_mark, Node node)         /*;premature_access*/
  2465. {
  2466.     /* Called when trying to use ( an access to) a fully private type.*/
  2467.     pass1_error_id("Premature usage of access, private or incomplete type %",
  2468.       type_mark, "7.4.2", node);
  2469.     return;
  2470. }
  2471.  
  2472. /* variations of this procedure are defined in errmsg.c */
  2473. void pass1_error(char *msg1, char *lrm_sec, Node node) /*;pass1_error*/
  2474. {
  2475.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  pass1_error");
  2476.  
  2477.     /* This procedure is invoked when a type error which requires a special
  2478.      * message is encountered in resolve1.
  2479.      */
  2480.  
  2481.     if (!noop_error)
  2482.         /* to avoid errmsg prepass */
  2483.         errmsg(msg1, lrm_sec, node);
  2484.     noop_error = TRUE;    /* To avoid cascaded errors.*/
  2485. }
  2486.  
  2487. char *full_type_name(Symbol typ)    /*;full_type_name*/
  2488. {
  2489.     /* Error message procedure. Restore source name of type, or if anonymous
  2490.      * build some approximate description of its ancestry.
  2491.      */
  2492.     /* Note that this is only called as part of error message and need ot
  2493.      * be provided until full error messages supported    ds 14 aug
  2494.      */
  2495.  
  2496.     char *type_name;
  2497.  
  2498.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  full_type_name");
  2499.  
  2500.     type_name = ORIG_NAME(typ);
  2501.     if (type_name == (char *)0 || strlen(type_name) == 0) { /* Anonymous type.*/
  2502.         /* TBSL: check above line for anonymous vs. undefined */
  2503.         if ( NATURE(typ) == na_subtype)
  2504.             type_name = full_type_name(TYPE_OF(typ));
  2505.         else if (NATURE(typ) == na_array)
  2506.             type_name = strjoin(strjoin("array(",
  2507.               full_type_name((Symbol) index_type(typ))), "...");
  2508.  
  2509.         else if (NATURE(typ) == na_type)        /* derived type */
  2510.             type_name = strjoin("new ", full_type_name(TYPE_OF(typ)));
  2511.         else type_name = strjoin("--anonymous--", "");
  2512.     }
  2513.     return type_name;
  2514. }
  2515.  
  2516. int is_type_node(Node node)                                    /*;is_type_node*/
  2517. {
  2518.     return (N_KIND(node) == as_simple_name && (is_type(N_UNQ(node))));
  2519. }
  2520.  
  2521. static int is_integer_type(Symbol sym)                    /*;is_integer_type*/
  2522. {
  2523.     return (sym == symbol_integer || sym == symbol_short_integer
  2524.       || sym == symbol_long_integer || sym == symbol_universal_integer);
  2525. }
  2526.  
  2527. static Triplet *triplet_new()
  2528. {
  2529.     return (Triplet *) emalloct(sizeof(Triplet), "triplet-new");
  2530. }
  2531.